Pasting between workbooks excel vba

Question

i have 50 workbooks and i made a code to copy from a main one the rows in which are the corespondent names to the other 49 files. the problem is in pasting to the 49 target files - paste method doesn't work. The errors is when the filter doesn't find entries for a name. How can i include a line that if the filter doesn't find a name in the main file, it will paste "no entries this month" in the file with the name that wasn't find? Thank you.

Any help is welcomed.

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

Set the last row separately.

' 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

Its probably much better to avoid copy/paste situations. This can get super time consuming over time.

try somethign like this instead:

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

This is a bit crude but I am sure you can significantly simplify your code if you do.

 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