从一个工作表复制数据的VBA代码&；粘贴到另一工作表的最后一行下方

我正在尝试编写一个代码，将数据从一个工作簿导入到另一个工作簿

源工作簿每次都会更改

目标工作簿是历史统计数据

将数据导入源工作表：工作表2后，我希望复制除标题和粘贴在目标工作表最后一行下方以外的所有数据：工作表1

我能够完成将数据导入工作表工作表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

---

我发现了错误。线路

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

---

最后，也用工作表限定

Cells（）

。

WS.Range（WS.Cells（2，1），WS.Cells（LastRow，LastCol））.EntireRow.Copy Destination:=工作表（“工作表1”）.Range（“A”）和工作表（“工作表1”）.Rows.Count.end（xlUp）.Offset（1，0）

？@BruceWayne:我刚刚试过，但是没有给出结果。你的代码比我从你的描述中猜出来的要复杂得多，请修改描述，或者删除代码中不相关的部分。你试过你的代码吗？它应该向您展示它所执行的所有步骤，您将能够看到它的行为与您预期的不同。@MátéJuhász：非常感谢您给我逐行调试的想法。我发现了错误。代码

WS.Range（单元格（2，1），单元格（LastRow，LastCol））.EntireRow.Copy目标：=工作表（“工作表1”）.Range（“A”和Rows.Count）.End（xlUp）.偏移量（1，0）

应该在循环开始之前。否则代码将在循环中运行并进入下一行。@MátéJuhász:将发布正确的代码作为答案。