合并具有相同标题的包含拆分数据的列

Question

我有一个 Excel 文件，其中第 2 行包含标题。其中一些标题是“克隆的”，并且数据在两个克隆之间划分（在下面的链接文件中，例如列 Q 和 T 以及 AK 和 AQ）。在 Q 列中有一些空单元格，T 包含要放入这些空单元格的数据。

请参阅以下文件以获取示例： https://dl.dropboxusercontent.com/u/18908464/Example.xlsx

我一直在寻找一种代码，用于在第 2 行中搜索具有相同标题的列，然后将它们合并到没有空单元格的一列中，如果可能的话，在合并后删除空列。

使用 Excel 2013。

Answer 1

此代码将合并所有具有重复标题的列

• 如果 Q 中的单元格为空，它会将重复列 (T) 中的数据带到其左侧的第一列 (Q)

将其粘贴到标准 VBA 模块中，然后在 VBA 中添加引用：

• 导航到工具 > 参考
• 向下滚动并选择 Microsoft 脚本运行时
• 单击代码中的任意位置并按 F5 运行它（在文件副本上）

---

Option Explicit

Public Sub mergeColumns()
   Const HDR As Long = 7      'header row
   Const HDC As Long = 2      '(first) header column

   Dim ws As Worksheet, lRow As Long, lCol As Long, hRow As Variant, i As Long
   Dim ac As New Dictionary, dc As New Dictionary, c1 As Variant, c2 As Variant
   Dim itm As Variant, dCols As Range, d As Range, tr As String
   Set ws = ThisWorkbook.Worksheets("Ark1")
   lRow = ws.Cells(ws.Rows.Count, HDC).End(xlUp).Row
   lCol = ws.Cells(HDR, ws.Columns.Count).End(xlToLeft).Column
   If lRow > HDR And lCol > HDC Then
      hRow = ws.Range(ws.Cells(HDR, HDC), ws.Cells(HDR, lCol)).Value2
      For i = 1 To lCol - HDC + 1 'find dupes ---------------------------------------------
         tr = Trim(hRow(1, i))
         If Len(tr) > 0 Then
            If ac.Exists(tr) Then dc.Add ac(tr), i + HDC - 1 Else ac.Add tr, i + HDC - 1
         End If
      Next
      Application.ScreenUpdating = False
      For Each itm In dc 'merge columns ---------------------------------------------------
         c1 = ws.Range(ws.Cells(HDR, itm), ws.Cells(lRow, itm)).Value2
         c2 = ws.Range(ws.Cells(HDR, dc(itm)), ws.Cells(lRow, dc(itm))).Value2
         For i = 1 To lRow - HDR + 1
            If Len(Trim(c1(i, 1))) = 0 Then c1(i, 1) = c2(i, 1) 'trimms blanks
         Next
         ws.Range(ws.Cells(HDR, itm), ws.Cells(lRow, itm)).Value2 = c1
      Next
      For Each itm In dc 'delete duplicate columns ----------------------------------------
         Set d = ws.Cells(HDR, dc(itm))
         If dCols Is Nothing Then Set dCols = d Else Set dCols = Union(dCols, d)
      Next
      If Not dCols Is Nothing Then dCols.EntireColumn.Delete
      Application.ScreenUpdating = True
   End If
End Sub

---

测试了大约 100 万条记录（总行数：994,503 行：3.9453125 秒）

---

编辑：

• 我进行了一项调整，以处理看似空白但实际上包含空格的字段

• 一些“空白”您的新文件包含 7 个空格（转换为 7 个字符，因此不是空白）

  • 示例：单元格 H54、55、56 等

我包含了一个 Trim() 函数，用于删除所有空格（制表符、回车等）

除了我调整的以外：

• Const HDR As Long =7
• Const HDC As Long =2

和

• Set ws = ThisWorkbook.Worksheets("Ark1")

前后的新文件：