Einfügen zwischen Arbeitsmappen Excel VBA

Question

Ich habe 50 Arbeitsmappen und ich habe einen Code erstellt, um aus einem Haupt die Zeilen, in denen die entsprechenden Namen sind, zu den anderen 49 Dateien zu kopieren. Das Problem liegt beim Einfügen in die 49 Zieldateien - die paste-Methode funktioniert nicht. Der Fehler tritt auf, wenn der Filter keine Einträge für einen Namen findet. Wie kann ich eine Zeile einfügen, wenn der Filter keinen Namen in der Hauptdatei findet, fügt er "keine Einträge in diesem Monat" in die Datei mit dem Namen ein, der nicht gefunden wurde? Vielen Dank.

Jede Hilfe ist willkommen.

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

Die letzte Zeile separat einstellen.

' 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

Es ist wahrscheinlich viel besser, Kopieren/Einfügen Situationen zu vermeiden. Dies kann im Laufe der Zeit super zeitaufwendig werden.

versuchen, wie diese statt somethign:

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

Das ist ein bisschen grob, aber ich bin sicher, dass Sie deutlich Ihren Code vereinfachen können, wenn Sie tun.

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