宏从一张表中逐列复制并粘贴到主表中，以保持不断增长的数据

Posted 2023-04-19

【中文标题】宏从一张表中逐列复制并粘贴到主表中，以保持不断增长的数据

【英文标题】：Macro to copy and paste column by column from one sheet into master sheet by header to maintain growing data

【发布时间】：2012-03-21 10:04:18

【问题描述】：

我对 Excel VBA 相当陌生，并且一直在尝试寻找（并提出自己的）解决方案来解决我面临的困境。通常，我从同事那里收到原始数据文件，这些原始数据文件可能有不同数量的列，但标题名称一致。我的工作簿中有一个主电子表格，我想通过附加新数据来保持最新状态（因此请继续将新电子表格的数据附加到下一个空行）。我想创建一个宏，可以获取导入的电子表格（例如电子表格 A）并查看列的标题值，复制列范围（从第 2 行开始到列内填充的末尾），转到电子表格 Master ，查找标题值，然后将列范围粘贴到列中的下一个空单元格中。此过程适用于电子表格 A 中存在的所有列。

非常感谢任何帮助/指导/建议。

例如）我有“主”表和“导入”表。我想获取“导入”表，查看第 1 行中的标题，从第 1 列开始。如果该标题存在于“主”表中，则从“导入表”复制列（减去标题）并粘贴到“ master”在相应的列标题下，从该列中的下一个空单元格开始。我最终想要做的是保留带有历史数据的“主”表，但“导入”表包含四处移动的列，所以我无法复制和粘贴从主中的下一个空单元格开始的范围。

【问题讨论】：

这段代码有什么问题？您具体需要更改哪些内容？

所有列的行数都相同吗？按照您的说明逐列粘贴第一个空单元格，这不会导致您的行错位吗？

【参考方案1】：

未经测试但编译正常：

Sub CopyByHeader()

    Dim shtA As Worksheet, shtB As Worksheet
    Dim c As Range, f As Range
    Dim rngCopy As Range, rngCopyTo

    Set shtA = ActiveSheet ' "incoming data" - could be different workbook
    Set shtB = ThisWorkbook.Sheets("Master")

    For Each c In Application.Intersect(shtA.UsedRange, shtA.Rows(1))

        'only copy if >1 value in this column (ie. not just the header)
        If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then

            Set f = shtB.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _
                                         LookAt:=xlWhole)
            If Not f Is Nothing Then

                Set rngCopy = shtA.Range(c.Offset(1, 0), _
                    shtA.Cells(Rows.Count, c.Column).End(xlUp))

                Set rngCopyTo = shtB.Cells(Rows.Count, _
                                f.Column).End(xlUp).Offset(1, 0)
                'copy values
                rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value

            End If
        End If
    Next c

End Sub

编辑：更新为仅复制具有任何内容的列，并且仅复制值

【讨论】：

嗨，蒂姆，代码似乎执行了复制和粘贴，但似乎不一致。在一种情况下，它还复制了标题。你能提供更多解决这个问题的方向吗？这些实例仅在该列在原始导入工作表中不包含任何值时发生。因此，如果 B 列在导入的工作表上没有值，它只会将标题复制到主工作表中。我还有另一个问题。如何修改代码以仅粘贴值？我能想到的唯一方法是使用 .PasteSpecial xlPasteValues 但没有成功。谢谢，非常感谢您的帮助。

蒂姆，感谢您提供的所有帮助和建议。非常感谢。

【参考方案2】：

我无法让上述工作，并且需要与原始问题相同的结果。关于缺少什么的任何想法？我以为我改变了所有需要改变的东西以适合我的床单：

Sub CopyByHeader()


Dim shtMain As Worksheet, shtImport As Worksheet

Dim c As Range, f As Range

Dim rngCopy As Range, rngCopyTo

Set shtImport = ActiveSheet

' "Import"

Set shtMain = ThisWorkbook.Sheets("Main")

For Each c In Application.Intersect(shtImport.UsedRange, shtImport.Rows(1))

'only copy if >1 value in this column (ie. not just the header)

If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then

Set f = shtMain.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _
LookAt:=xlWhole)

If Not f Is Nothing Then

Set rngCopy = shtImport.Range(c.Offset(1, 0), _
shtImport.Cells(Rows.Count, c.Column).End(xlUp))
Set rngCopyTo = shtMain.Cells(Rows.Count, _
f.Column).End(xlUp).Offset(1, 0)

'copy values

rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value

End If

 End If

 Next c

 End Sub

谢谢， 瑞恩