あるワークシートのデータをコピーして別のワークシートの最後の行の下に貼り付けるVBAコード

Question

あるブックから別のブックへデータをインポートするコードを作成しようとしています。

ソースブックは毎回変更されます。

ターゲットワークブックはソースワークシートにデータをインポートした後履歴統計情報

です：シート2、私はの最後の行の下のヘッダー&ペーストを除く全データをコピーしたいですターゲットシート：シート1

私はtのインポートの最初の部分を行うことができますワークシートへのデータシート2。しかし、コピー＆ペーストのコードが実行されてもエラーを出さないにもかかわらず、結果が得られない理由はわかりません。したがって、エラーを見つけることができず、何がうまくいかないのか理解できません。

問題を理解する助けてください！ありがとう！ :)

これは私のコードです：

Public Sub Add_Data() 

Application.ScreenUpdating = False 

Dim TabName As String 

TabName = "Sheet 2" 

ActiveSheet.Name = TabName 

count1 = Workbooks("History Statistics.xlsm").Sheets.Count 
Sheets(TabName).Copy After:=Workbooks("History Statistics.xlsm").Sheets(count1) 

Workbooks("History Statistics.xlsm").Activate 

MsgBox ("Data has been added to the master file") 

Dim WS As Worksheet 
Dim ColList As String, ColArray() As String 
Dim LastCol As Long, LastRow As Long, i As Long, j As Long 
Dim boolFound As Boolean 
Dim delCols As Range 

On Error GoTo Whoa 

Application.ScreenUpdating = False 

'~~> Set your sheet here 
Set WS = Sheets("Sheet 2") 

'~~> List of columns you want to keep. You can keep adding or deleting from this. 
'~~> Just ensure that the column names are separated by a COMMA 
'~~> The names below can be in any case. It doesn't matter 
ColList = "Object Code, Points, Type, F, Module, Global Resp. Area" 

'~~> Create an array for comparision 
ColArray = Split(ColList, ",") 

'~~> Get the last column 
LastCol = WS.Cells.Find(What:="*", After:=WS.Range("A1"), Lookat:=xlPart, _ 
LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _ 
MatchCase:=False).Column 

'~~> Get the last row 
LastRow = WS.Cells.Find(What:="*", After:=WS.Range("A1"), Lookat:=xlPart, _ 
LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ 
MatchCase:=False).Row 

'~~> Loop through the Cols 
For i = 1 To LastCol 
    boolFound = False 
    '~~> Checking of the current cell value is present in the array 
    For j = LBound(ColArray) To UBound(ColArray) 
     If UCase(Trim(WS.Cells(1, i).Value)) = UCase(Trim(ColArray(j))) Then 
      '~~> Match Found 
      boolFound = True 
      Exit For 
     End If 
    Next 
    '~~> If match not found 
    If boolFound = False Then 
     If delCols Is Nothing Then 
      Set delCols = WS.Columns(i) 
     Else 
      Set delCols = Union(delCols, WS.Columns(i)) 
     End If 
    End If 
Next i 

'~~> Delete the unwanted columns 
If Not delCols Is Nothing Then delCols.Delete 

LetsContinue: 
Application.ScreenUpdating = True 
Exit Sub 
Whoa: 
MsgBox Err.Description 
Resume LetsContinue 

WS.Range(Cells(2, 1), Cells(LastRow, LastCol)).EntireRow.Copy Destination:=Sheets("Sheet 1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 

End Sub 

Answer 1

私はエラーを考え出しました。ループが始まる前に、線

WS.Range(Cells(2, 1), Cells(LastRow, LastCol)).EntireRow.Copy Destination:=Sheets("Sheet 1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 

が必要です。それ以外の場合、コードはループ内で実行され、次の行に移動します。終わり

Public Sub Add_Data() 

Application.ScreenUpdating = False 

Dim TabName As String 

TabName = "Sheet 2" 

ActiveSheet.Name = TabName 

count1 = Workbooks("History Statistics.xlsm").Sheets.Count 
Sheets(TabName).Copy After:=Workbooks("History Statistics.xlsm").Sheets(count1) 

Workbooks("History Statistics.xlsm").Activate 

MsgBox ("Data has been added to the master file") 

Dim WS As Worksheet 
Dim ColList As String, ColArray() As String 
Dim LastCol As Long, LastRow As Long, i As Long, j As Long 
Dim boolFound As Boolean 
Dim delCols As Range 

On Error GoTo Whoa 

Application.ScreenUpdating = False 

'~~> Set your sheet here 
Set WS = Sheets("Sheet 2") 

'~~> List of columns you want to keep. You can keep adding or deleting from this. 
'~~> Just ensure that the column names are separated by a COMMA 
'~~> The names below can be in any case. It doesn't matter 
ColList = "Object Code, Points, Type, F, Module, Global Resp. Area" 

'~~> Create an array for comparision 
ColArray = Split(ColList, ",") 

'~~> Get the last column 
LastCol = WS.Cells.Find(What:="*", After:=WS.Range("A1"), Lookat:=xlPart, _ 
LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _ 
MatchCase:=False).Column 

'~~> Get the last row 
LastRow = WS.Cells.Find(What:="*", After:=WS.Range("A1"), Lookat:=xlPart, _ 
LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ 
MatchCase:=False).Row 

'~~> Loop through the Cols 
For i = 1 To LastCol 
boolFound = False 
'~~> Checking of the current cell value is present in the array 
For j = LBound(ColArray) To UBound(ColArray) 
    If UCase(Trim(WS.Cells(1, i).Value)) = UCase(Trim(ColArray(j))) Then 
     '~~> Match Found 
     boolFound = True 
     Exit For 
    End If 
Next 
'~~> If match not found 
If boolFound = False Then 
    If delCols Is Nothing Then 
     Set delCols = WS.Columns(i) 
    Else 
     Set delCols = Union(delCols, WS.Columns(i)) 
    End If 
End If 
Next i 

'~~> Delete the unwanted columns 
If Not delCols Is Nothing Then delCols.Delete 

'copy-paste after last row 
WS.Range(Cells(2, 1), Cells(LastRow, LastCol)).EntireRow.Copy Destination:=Sheets("Sheet 1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 

LetsContinue: 
Application.ScreenUpdating = True 
Exit Sub 
Whoa: 
MsgBox Err.Description 
Resume LetsContinue 
End Sub