Excel 按列名重命名列并与其他图纸合并

我有两个类似的数据集/范围，在单独的表格中，都从单元格A1开始。这两个表格分别命名为“表1”和“表2”

sheetname:table1上的第一个表如下所示：

sheetname:表2上的第二个表如下：

表中的列表示相同的内容，但名称不同，或顺序不同

我试图根据名称来匹配这些列（“学校名称”=“学校地址”，“粉笔”=“粉笔盒”，“掸子”=“擦除器”，“黑板”=“黑板”，“尺子”=“标尺”）

我需要将第二个表合并到第一个表中，保留第一个表的列标题。如果数据中有空白，我也需要它工作

最终产品（在新表或表1上）应如下所示：

很抱歉，我是VBA新手。我可以用

Sheets（“TABLE2”）.范围（“A1:E5”）.复制目的地：=Sheets（“TABLE1”）.范围（“D1”）

但是，要跨多行复制我的模拟表，这不会执行匹配，并且如果有其他行，也不起作用

---

非常感谢您的帮助。

请尝试此代码。它将匹配标题等价项（存储在

arrEch

）并一次复制每一列：

Sub testMatchTables()
  Dim shT1 As Worksheet, shT2 As Worksheet, lastR1 As Long, lastR2 As Long
  Dim arrEch As Variant, arrInt As Variant, El As Variant, matchRng1 As Range, matchRng2 As Range

    Set shT1 = Worksheets("TABLE1")
    Set shT2 = Worksheets("TABLE2")
     lastR1 = shT1.Range("A" & Rows.Count).End(xlUp).row
     lastR2 = shT2.Range("A" & Rows.Count).End(xlUp).row
     arrEch = Split("school name|school address,chalk|chalk box,duster|erasor,board|blackboard,ruler|measuring stick", ",")
     'Check the headers equivalence (for spelling errors):
     If Not ChechEquivalence(arrEch, shT1, shT2) Then Exit Sub
     For Each El In arrEch
        arrInt = Split(El, "|") 'extract each header from the "|" separated array element
        Set matchRng1 = shT1.Rows(1).Find(arrInt(0))
        Set matchRng2 = shT2.Rows(1).Find(arrInt(1))
        If Not matchRng1 Is Nothing And Not matchRng2 Is Nothing Then
            shT1.Cells(lastR1 + 1, matchRng1.Column).Resize(lastR2 - 1, 1).Value = _
                    shT2.Range(matchRng2.Offset(1), shT2.Cells(lastR2, matchRng2.Column)).Value
        End If
     Next
End Sub
'The next function check the matching headers equivalence:
Private Function ChechEquivalence(arr As Variant, shT1 As Worksheet, shT2 As Worksheet) As Boolean
   Dim El As Variant, arrInt As Variant, matchRng1 As Range, matchRng2 As Range
   For Each El In arr
        arrInt = Split(El, "|")
        Set matchRng1 = shT1.Rows(1).Find(arrInt(0))
        Set matchRng2 = shT2.Rows(1).Find(arrInt(1))
        If matchRng1 Is Nothing Then
            MsgBox "Eny equivalence between """ & arrInt(0) & """ could be find in """ & shT1.Name & """ header!" & vbCrLf & _
                "Please, check the array definition of this element, correct it and try again.", vbInformation, "Wrong Header spellinig"
            ChechEquivalence = False: Exit Function
        If matchRng2 Is Nothing Then
            MsgBox "Eny equivalence between """ & arrInt(1) & """ could be find in """ & shT2.Name & """ header!" & vbCrLf & _
                "Please, check the array definition of this element, correct it and try again.", vbInformation, "Wrong Header spellinig"
            ChechEquivalence = False: Exit Function
        End If
     Next
     ChechEquivalence = True
End Function

---

等价性检查的方法允许数组头的等价性定义与实际头的拼写之间存在细微差异。我的意思是将找到“标尺

”（而不是
标尺“”），并且在这种情况下代码也会运行良好…
请尝试此代码。它将匹配标题等价项（存储在
arrEch
）并一次复制每一列：

Sub testMatchTables()
  Dim shT1 As Worksheet, shT2 As Worksheet, lastR1 As Long, lastR2 As Long
  Dim arrEch As Variant, arrInt As Variant, El As Variant, matchRng1 As Range, matchRng2 As Range

    Set shT1 = Worksheets("TABLE1")
    Set shT2 = Worksheets("TABLE2")
     lastR1 = shT1.Range("A" & Rows.Count).End(xlUp).row
     lastR2 = shT2.Range("A" & Rows.Count).End(xlUp).row
     arrEch = Split("school name|school address,chalk|chalk box,duster|erasor,board|blackboard,ruler|measuring stick", ",")
     'Check the headers equivalence (for spelling errors):
     If Not ChechEquivalence(arrEch, shT1, shT2) Then Exit Sub
     For Each El In arrEch
        arrInt = Split(El, "|") 'extract each header from the "|" separated array element
        Set matchRng1 = shT1.Rows(1).Find(arrInt(0))
        Set matchRng2 = shT2.Rows(1).Find(arrInt(1))
        If Not matchRng1 Is Nothing And Not matchRng2 Is Nothing Then
            shT1.Cells(lastR1 + 1, matchRng1.Column).Resize(lastR2 - 1, 1).Value = _
                    shT2.Range(matchRng2.Offset(1), shT2.Cells(lastR2, matchRng2.Column)).Value
        End If
     Next
End Sub
'The next function check the matching headers equivalence:
Private Function ChechEquivalence(arr As Variant, shT1 As Worksheet, shT2 As Worksheet) As Boolean
   Dim El As Variant, arrInt As Variant, matchRng1 As Range, matchRng2 As Range
   For Each El In arr
        arrInt = Split(El, "|")
        Set matchRng1 = shT1.Rows(1).Find(arrInt(0))
        Set matchRng2 = shT2.Rows(1).Find(arrInt(1))
        If matchRng1 Is Nothing Then
            MsgBox "Eny equivalence between """ & arrInt(0) & """ could be find in """ & shT1.Name & """ header!" & vbCrLf & _
                "Please, check the array definition of this element, correct it and try again.", vbInformation, "Wrong Header spellinig"
            ChechEquivalence = False: Exit Function
        If matchRng2 Is Nothing Then
            MsgBox "Eny equivalence between """ & arrInt(1) & """ could be find in """ & shT2.Name & """ header!" & vbCrLf & _
                "Please, check the array definition of this element, correct it and try again.", vbInformation, "Wrong Header spellinig"
            ChechEquivalence = False: Exit Function
        End If
     Next
     ChechEquivalence = True
End Function

等价性检查的方法允许数组头的等价性定义与实际头的拼写之间存在细微差异。我的意思是“标尺
将被找到（而不是
标尺”），代码在这种情况下也会运行良好……
您总是匹配列而不是行吗？也许您可以对列进行排序，然后跨多个列进行复制。或者使用match查找第1行中的标题并通过该方式进行复制。或者使用查找公式。我需要在实际工作表中查找大约50列，并且原始工作表需要按照原始顺序，因此即使我重命名了列并从左到右排序，我能把数据放回去吗？你总是匹配列而不是行吗？也许您可以对列进行排序，然后跨多个列进行复制。或者使用match查找第1行中的标题并通过该方式进行复制。或者使用查找公式。我需要在实际工作表中查找大约50列，并且原始工作表需要按照原始顺序，因此即使我重命名了列并从左到右排序，我能把数据放回去吗？谢谢-我已经运行了第一个函数，它工作得很好。我对名字做了一些细微的改动，它仍然有效。我还没有尝试第二个函数，它的目的是在列名与编码名称不匹配时提供警告吗？@Sean:事实上，你已经检查过了。。。main sub调用它以检查拼写。正如我所写的，如果数组中的字符串存在于头字符串中，那么代码能够匹配头字符串…感谢这一点-我已经运行了第一个函数，它工作得非常好。我对名字做了一些细微的改动，它仍然有效。我还没有尝试第二个函数，它的目的是在列名与编码名称不匹配时提供警告吗？@Sean:事实上，你已经检查过了。。。main sub调用它以检查拼写。就像我写的，如果数组中的字符串存在于头字符串中，那么代码能够匹配头。。。