在工作簿之間粘貼Excel VBA

Question

我有50個工作簿，我編寫了一個代碼，可以從一個主要的行中將對應的行復制到其他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

避免復制/粘貼情況可能更好。 隨着時間的流逝，這可能會浪費大量時間。

嘗試這樣的東西：

 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