excel vba基于单元格范围中列出的列标题复制多列

我想根据列标题（例如日期、名称、ID、金额等）将多个列从sheet1复制到sheet2，列标题列在sheet3中，A1:A10.eg。日期、姓名、身份证、金额等

在谷歌搜索了几个小时后，我得到了下面的代码，但它只能复制一列，我怎么能复制多列呢？我需要更改代码的哪一部分？非常感谢您的时间和帮助

多谢各位

Sub CopySpecifcColumn()

    Set MR = Range("A1:e1")

    For Each cell In MR

        If cell.Value = "Date" Then cell.EntireColumn.Copy

    Next

End Sub

---

您只复制一列（“日期”列），因为If语句只复制日期列。通过继续使用当前方法，您可以通过为以下列编写语句来复制

范围（“A1:e1”）

中其余数据的列：

Set MR = Range("A1:e1")

For Each cell In MR

If cell.Value = "Date" Then 
    cell.EntireColumn.Copy
End If

If cell.Value = "Name" Then    '<- Add these for each column title
    cell.EntireColumn.Copy
End If 

If cell.Value = "ID" Then 
    cell.EntireColumn.Copy
End If

If cell.Value = "Amount" Then 
    cell.EntireColumn.Copy
End If


Next cell

未经测试：

Sub CopyCols()

    Dim h As Range, f As Range, sht1, rngDest As Range

    Set sht1 = ThisWorkbook.Sheets("Sheet1")
    Set rngDest = ThisWorkbook.Sheets("Sheet2").Range("a1") 'start pasting here

    'loop through the headers to copy
    For Each h In ThisWorkbook.Sheets("Sheet3").Range("A1:A10").Cells
        'find the header on sheet1
        Set f = sht1.Rows(1).Find(h.Value, , xlValues, xlWhole)
        If Not f Is Nothing Then
            'found the header: copy the column
            f.EntireColumn.Copy rngDest
            Set rngDest = rngDest.Offset(0, 1) ' move destination
        End If
        Set f = Nothing
    Next h

End Sub

---

这里有两种可能性

这一个更符合您的代码。您需要检查表3 A1:A10中是否存在

单元格.Value

，而不是检查

单元格.Value

Find

方法在这里应该很好，但是，如果找不到值，它将返回错误。请注意这一点

这一个将以另一种方式工作。对于Sheet3 A1:A10中的每个单元格，在sheet1中找到列标题并复制该列

Find

方法将在这里再次起作用，但只要您在Sheet3中保持名称不出现拼写错误，它将更安全

---

当然，在复制下一列之前，仍然需要粘贴复制的数据。第三种方法是选择所有列，然后复制所有列，但我发现这更复杂，粘贴的数据可能有空列。

嗨，Anthony，谢谢分享。我尝试了你的代码，但它只复制了最后一个标题，即金额，没有选择日期、姓名和ID，代码中缺少任何内容？@Robin我已对代码进行了调整。仅复制最后一个头的问题是因为If语句没有结束。为每个If语句添加一个End将确保每个If语句都能运行。在使用数组编写这篇文章时，我将在完成代码编写后更新我的答案。感谢您的时间和帮助！！安东尼，让我稍后再试，然后再回来找你。谢谢。嗨，这是另一种方法，太好了！谢谢你们，你们真是太棒了！

Sub CopyCols()

    Dim h As Range, f As Range, sht1, rngDest As Range

    Set sht1 = ThisWorkbook.Sheets("Sheet1")
    Set rngDest = ThisWorkbook.Sheets("Sheet2").Range("a1") 'start pasting here

    'loop through the headers to copy
    For Each h In ThisWorkbook.Sheets("Sheet3").Range("A1:A10").Cells
        'find the header on sheet1
        Set f = sht1.Rows(1).Find(h.Value, , xlValues, xlWhole)
        If Not f Is Nothing Then
            'found the header: copy the column
            f.EntireColumn.Copy rngDest
            Set rngDest = rngDest.Offset(0, 1) ' move destination
        End If
        Set f = Nothing
    Next h

End Sub