VBA代码可从一个工作表复制数据并将其粘贴到另一工作表的最后一行下方

Question

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

源工作簿将每次更改。

目标工作簿是“ 历史统计”

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

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