excel - 无法将数据附加到现有数据

问题描述

我已经有一个包含一些数据的主数据集。我正在尝试通过匹配列名并将相应数据复制粘贴到我无法执行的主文件中，将另一个 Excel 工作表中的其他数据附加到此主数据集中。

我的主数据集的数据顺序与我需要附加的新数据的顺序不同。因此，我的代码在目标（主数据集）和源（Excel 中的新数据）中查找匹配的标题，并尝试在匹配列下复制和粘贴相应的值。


Sub AppendData()

' AppendData Macro

Application.ScreenUpdating = False

' create worksheet objects
Dim shtSource As Worksheet
Dim shtTarget As Worksheet
Dim strFile As String

Set shtTarget = ActiveWorkbook.Sheets("MASTER - Formatted")
strFile = ActiveWorkbook.Worksheets("Macro").Range("C2").Value
If CStr(strFile) <> "False" Then

        Set shtSource = Workbooks.Open(strFile).Sheets(1)

        ' create range objects
        Dim rngSourceHeaders As Range: Set rngSourceHeaders = shtSource.Range("B1:S1")

        shtTarget.Activate
        With shtTarget
            Dim rngTargetHeaders As Range: Set rngTargetHeaders = .Range("K1:AA1") '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
            Dim rngPastePoint As Range: Set rngPastePoint = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) 'Shoots up from the bottom of the sheet untill it bumps into something and steps one down
        End With

Dim rngDataColumn As Range

        ' process data
        Dim cl As Range, i As Integer
        For Each cl In rngTargetHeaders ' loop through each cell in target header row


            ' identify source location
            shtSource.Activate
            i = 0 ' reset I
            On Error Resume Next ' ignore errors, these are where the value can't be found and will be tested later
                i = Application.Match(cl.Value, rngSourceHeaders, 0) 'Finds the matching column name
            On Error GoTo 0 ' switch error handling back off

            ' report if source location not found
            If i = 0 Then
                intErrCount = intErrCount + 1
                Debug.Print "unable to locate item [" & cl.Value & "] at " & cl.Address ' this reports to Immediate Window (Ctrl + G to view)
                GoTo nextCL
            End If

        ' create source data range object
            With rngSourceHeaders.Cells(1, i)
                Set rngDataColumn = Range(.Cells(2, 1), .Cells(1000000, 1).End(xlUp))
            End With

            ' pass to target range object
            shtTarget.Activate
            cl.Offset(1, 0).Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value

nextCL:
        Next cl

        Application.CutCopyMode = False

        shtSource.Activate
        ActiveWorkbook.Close False


        Else

        Application.ScreenUpdating = True

        MsgBox "No valid file selected", vbOKOnly + vbInformation, "Copy Error"


End If

End Sub

目前，如果我的主表只有标题而没有现有数据，我的代码工作得很好。如果我运行此代码，它会将所有新数据粘贴到第 2 行的匹配列下（第 1 行是标题）。

但它不会附加到我想要的输出的最后一个现有行。

我目前在主数据集中大约有 20000 行，例如，我需要从第 20001 行追加新数据。

感谢您对此代码的一些帮助。

谢谢！

标签： excelvba

excel - 无法将数据附加到现有数据

问题描述

解决方案

推荐阅读