ワークブック間のペースト

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

おそらく、コピー/貼り付けの状況を避ける方がずっと良いです。これは、時間の経過とともに超時間を消費する可能性があります。

ではなく、このよう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