粘贴Excel VBA中

Question

我有50个工作簿和我犯了一个代码从一个主一个行中哪个是corespondent名称其他49页的文件复制。问题在于粘贴到49个目标文件 - 粘贴方法不起作用。错误是当筛选器未找到名称条目时。我怎么能包括一行，如果过滤器没有在主文件中找到一个名字，它会在文件中粘贴“本月没有条目”，而这个名字是找不到的？谢谢。

欢迎任何帮助。

Sub name1() 

    Dim ws As Worksheet 
    Dim rng As Range, rngA As Range, rngB As Range 
    Dim LRow As Long 
    Set ws = Sheets("name list") 
    With ws 
     LRow = .Range("A" & .Rows.Count).End(xlUp).Row 
     Set rng = .Range("A1:M" & LRow) 
     .AutoFilterMode = False 
     With rng 
      .AutoFilter Field:=12, Criteria1:="name1" 
      Set rngA = .Offset(1, 0).SpecialCells(xlCellTypeVisible) 
     End With 
     .AutoFilterMode = False 
      With rng 
      .AutoFilter Field:=13, Criteria1:="name1" 
      Set rngB = .Offset(1, 0).SpecialCells(xlCellTypeVisible) 
      End With 
     .AutoFilterMode = False 
     rng.Offset(1, 0).EntireRow.Hidden = True 
     Union(rngA, rngB).EntireRow.Hidden = False 
    End With 
End Sub 

Sub name11() 
    Dim lst As Long 
    Dim rng As Range 
    Dim i As Integer 
    Set rng = Application.Intersect(ActiveSheet.UsedRange, Range("A:M")) 
    rng.SpecialCells(xlCellTypeVisible).Select 
    Selection.Copy 
    Application.DisplayAlerts = False 

    Workbooks.Open Filename:= _ 
     "\\HOFS\persons\name1.xlsm" _ 
     , UpdateLinks:=true 

    With Sheets("tribute").Range("A" & Rows.Count).End(xlUp).Offset(1) 
    '.PasteSpecial Paste:=xlPasteColumnWidths 
    .PasteSpecial Paste:=xlPasteValues 
    End With 

ActiveWorkbook.Close SaveChanges:=True 
Application.DisplayAlerts = False 

    Windows("name list.xlsm").Activate 
    rng.Offset(1, 0).EntireRow.Hidden = False 

End Sub 

Sub TRANSFER_name1() 

Call name1 
Call name11 

End Sub 

Answer 1

单独设置最后一行。

' Gives the first empty row in column 1 (A) 
lastRow = Worksheets("tribute").Cells(Worksheets("tribute").Rows.Count, 1).End(xlUp).Row + 1 
' Pastes values 
Worksheets("tribute").Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues 

Answer 2

它可能要好得多，以避免复制/粘贴的情况。随着时间的推移，这会花费超级时间。

尝试somethign像这个：

With Sheets("tribute").Range("A" & Rows.Count).End(xlUp).Offset(1).value = rng.Value 

这是一个有点粗糙，但我相信你可以显著简化你的代码，如果你做的。

Dim wbk As Workbook 
Dim Filename As String 
Dim path As String 
Dim rCell As Range 
Dim rRng As Range 
Dim wsO As Worksheet 
Dim StartTime As Double 
Dim SecondsElapsed As Double 
Dim sheet As Worksheet 

Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Application.Calculation = xlCalculationManual 

StartTime = Timer 

path = "pathtofolder" & "\" 
Filename = Dir(path & "*.xl??") 
Set wsO = ThisWorkbook.Sheets("Sheet1") 

Do While Len(Filename) > 0 
    DoEvents 
    Set wbk = Workbooks.Open(path & Filename, True, True) 
       Set rRng = sheet.Range("b1:b308") 
       For Each rCell In rRng.Cells 
        wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(1, 0).Value = rCell 
       Next rCell 
    wbk.Close False 
    Filename = Dir 
Loop 

Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
Application.Calculation = xlCalculationAutomatic 

SecondsElapsed = Round(Timer - StartTime, 2) 
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation