在工作簿之间粘贴excel vba

我有50个工作簿，我做了一个代码，从一个主要的行复制其他49个文件的核心名称。 问题是粘贴到49个目标文件 – 粘贴方法不起作用。 错误是当filter没有find名称的条目。 我怎么能包括一行，如果filter没有在主文件中find一个名字，它会粘贴“没有这个月的条目”的文件名称是找不到？ 谢谢。

欢迎任何帮助。

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

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

尝试这样的事情，而不是：

  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