Vba 按标题值复制列

我想通过确定列的单元格值，将列从excel“Book1”复制到另一个excel“Book2”

假设Book1中的标题列是姓名、年龄、性别、地址和组。我想把“姓名”、“年龄”和“组别”一栏复制到“Book2”。下面的编码是我通过单元格坐标提取列数据所做的工作

是否可以从标题值中提取列

Sub copyColumns()

    Dim lr As Long, r As Long

    Set src = ThisWorkbook.Worksheets("Sheet1")
    Set tgt = Workbooks("Book2.xlsx").Worksheets("Sheet1")

    lr = src.Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To lr

        src.Cells(i, 1).copy
        r = tgt.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

        src.Paste Destination:=tgt.Cells(r, 1)

        src.Cells(i, 2).copy
        src.Paste Destination:=tgt.Cells(r, 2)

        src.Cells(i, 5).copy
        src.Paste Destination:=tgt.Cells(r, 3)

    Next i

End Sub

---

如果要逐列复制标题，可以使用此函数获取标题的字母：

Function Letter(oSheet As Worksheet, name As String, Optional num As Integer)
If num = 0 Then num = 1
Letter = Application.Match(name, oSheet.Rows(num), 0)
Letter = Split(Cells(, Letter).Address, "$")(1)
End Function

实施：

Sub copycolum()
Dim ws As Worksheet, ws2 As Worksheet

Set ws = Sheets("Sheet1"): Set ws2 = Sheets("Sheet2"):

ws.Range(Letter(ws, "Gender") & "2:" & Letter(ws, "Gender") & ws.Range(Letter(ws, "Gender") & "1000000").End(xlUp).Row).Copy Destination:=ws2.Range(Letter(ws2, "Gender") & "2")

End Sub

---

请注意，该函数在第1行设置为默认值，换句话说，您的标题位于第1列，如果您愿意，可以将其更改为数据所在的任何行

如果要逐列复制标题，可以使用此函数获取标题的字母：

Function Letter(oSheet As Worksheet, name As String, Optional num As Integer)
If num = 0 Then num = 1
Letter = Application.Match(name, oSheet.Rows(num), 0)
Letter = Split(Cells(, Letter).Address, "$")(1)
End Function

实施：

Sub copycolum()
Dim ws As Worksheet, ws2 As Worksheet

Set ws = Sheets("Sheet1"): Set ws2 = Sheets("Sheet2"):

ws.Range(Letter(ws, "Gender") & "2:" & Letter(ws, "Gender") & ws.Range(Letter(ws, "Gender") & "1000000").End(xlUp).Row).Copy Destination:=ws2.Range(Letter(ws2, "Gender") & "2")

End Sub

---

请注意，该函数在第1行设置为默认值，换句话说，您的标题位于第1列，如果您愿意，可以将其更改为数据所在的任何行

这个问题有很多解决方案。例如，声明变量：

Dim rw As Range
Dim cl As Range
Dim sFields As String
Dim V
Dim j As Integer

选择要复制的列名：

sFields = "Name|Age|Group"
V = Split(sFields, "|")

然后，在For i循环中，再做两个循环：

For Each cl In Intersect(src.Rows(i), src.UsedRange)
    For j = 0 To UBound(V)
        If cl.EntireColumn.Range("A1") = V(j) Then
           tgt.Cells(i, j).Value = src.Cells(i, j).Value
        End If
    Next j
Next cl

---

Intersect（src.Rows（i）、src.UsedRange）将选择实际使用范围内行中的所有单元格（即，它不会在所有16 384列中循环。所有列名称都在一个变量字段中，您可以轻松修改它。它是用管道分隔的字符串，您可能永远不会使用管道（|）在您的字段名称中，这样做是安全的。

此问题有许多解决方案。例如，声明变量：

Dim rw As Range
Dim cl As Range
Dim sFields As String
Dim V
Dim j As Integer

选择要复制的列名：

sFields = "Name|Age|Group"
V = Split(sFields, "|")

然后，在For i循环中，再做两个循环：

For Each cl In Intersect(src.Rows(i), src.UsedRange)
    For j = 0 To UBound(V)
        If cl.EntireColumn.Range("A1") = V(j) Then
           tgt.Cells(i, j).Value = src.Cells(i, j).Value
        End If
    Next j
Next cl

---

Intersect（src.Rows（i）、src.UsedRange）将选择实际使用范围内行中的所有单元格（即，它不会在所有16 384列中循环。所有列名称都在一个变量字段中，您可以轻松修改它。它是用管道分隔的字符串，您可能永远不会使用管道（|）在您的字段名称中，这样做是安全的。

在此过程中有一些提示：

• 始终在模块开头声明要使用的每个变量和用户选项
• 不要复制每个单元格，复制一个范围

请参阅下面的更新代码：

Sub copyColumns2()
Dim src As Worksheet, tgt As Worksheet
Dim lr As Long, r As Long, I As Long, Col As Long
Dim ColsToCopy, ColToCopy, counter As Integer
ColsToCopy = Array("Name", "Age", "Group")

Set src = ThisWorkbook.Worksheets("Sheet1")
Set tgt = Workbooks("Book2.xlsx").Worksheets("Sheet1")
lr = src.Cells(Rows.Count, 1).End(xlUp).Row

For Col = 1 To 20
    For Each ColToCopy In ColsToCopy
        If src.Cells(2, Col).Value = ColToCopy Then
            counter = counter + 1
            src.Range(src.Cells(2, Col), src.Cells(lr, Col)).Copy tgt.Cells(2, counter)
            Exit For
        End If
    Next ColToCopy
Next Col

End Sub

---

在此过程中有几点提示：

• 始终在模块开头声明要使用的每个变量和用户选项
• 不要复制每个单元格，复制一个范围

请参阅下面的更新代码：

Sub copyColumns2()
Dim src As Worksheet, tgt As Worksheet
Dim lr As Long, r As Long, I As Long, Col As Long
Dim ColsToCopy, ColToCopy, counter As Integer
ColsToCopy = Array("Name", "Age", "Group")

Set src = ThisWorkbook.Worksheets("Sheet1")
Set tgt = Workbooks("Book2.xlsx").Worksheets("Sheet1")
lr = src.Cells(Rows.Count, 1).End(xlUp).Row

For Col = 1 To 20
    For Each ColToCopy In ColsToCopy
        If src.Cells(2, Col).Value = ColToCopy Then
            counter = counter + 1
            src.Range(src.Cells(2, Col), src.Cells(lr, Col)).Copy tgt.Cells(2, counter)
            Exit For
        End If
    Next ColToCopy
Next Col

End Sub

---

当我尝试此操作时，它会在“Letter=Split（Cells（，Letter）.Address，$”（1）”这一行提示一个错误“Type mismatch”。为什么会发生这种情况？是否更改了“INSERTCOLUMNHEADERHERE”，该错误通常在找不到列标题时发生。我确实替换了该错误，但为了弄清楚，共有4个“INSERTCOLUMNHEADERHERE”我需要替换的字段。您能解释一下每个字段需要替换哪个标题吗？假设标题列是名称、年龄、性别、地址和组，我只想复制列名、年龄和组。@AjMal我更新了它的性别，您仍然得到类型不匹配错误吗？当我尝试此操作时，它提示一个错误“Letter=Split（Cells（，Letter）.Address，“$”（1）”这一行中的“Type mismatch”。为什么会发生这种情况？是否更改了“INSERTCOLUMNHEADERHERE”，当您找不到列标题时通常会发生此错误。我确实替换了它，但为了弄清楚，共有4个“INSERTCOLUMNHEADERHERE”"我需要替换的字段。您能解释一下每个字段需要替换哪个标题吗？假设标题列是名称、年龄、性别、地址和组，我只想复制列名、年龄和组。@AjMal我更新了它的性别，您仍然收到类型不匹配错误吗？我复制了与您的完全相同的更新代码选项显式并尝试运行，但没有结果。我是否遗漏了什么？它与我的测试工作簿配合得很好。是否收到错误消息？是否将代码放入正确的工作簿中，并且是否填充了第一列以确定总行数（您在代码中使用了相同的行数）？可能您的标题不同（小写/大写、尾随空格等）？您可以通过将

如果src.Cells（2，Col）.Value=ColToCopy更改为
如果trim（lcase（src.Cells（2，Col.Value））=lcase（ColToCopy）那么
在哪一行是标题？如果它们不在第2行，请更改
如果src.Cells（2，Col）.Value=ColToCopy然后相应地
。我的标题在两个工作簿的第1行。但它仍然不起作用。我使用Option Explicit复制了与您完全相同的更新代码，并尝试运行，但它没有运行。我错过了什么吗？它与我的测试工作簿配合得很好。您收到错误消息了吗？您是否将代码放入了t这是正确的工作簿，是确定行总数的第一列（您在代码中使用了相同的行）？可能您的标题不同（小写/大写、尾随空格等）？您可以通过将
If src.Cells（2，Col）.Value=ColToCopy更改为
If trim（lcase（src.Cells（2，Col）.Value））=lcase（ColToCopy）来增强代码然后
您的标题在哪一行？如果它们不在第2行，请更改行
如果src.Cells（2，Col）.Value=ColToCopy，则相应地
我的标题在两个工作簿的第1行。但它仍然无法工作