搜索特定的列标题名称，复制列并粘贴以追加到其他wookbooksheet

Question

我的工作簿包含一个，两个或三个工作表。 每张表至少可以包含以下列标题名称之一：“Tel”或“Number”。

如何复制包含这些列标题名称 的整个列（仅用于数据），并将它们（作为仅具有相同列标题名称的一列中的附加内容）粘贴到另一个工作簿工作表中，其中VBA代码（Sheet Module ）是。谢谢。

Answer 1

Option Compare Text 

Sub search_and_append() 

    Dim i As Long 
    Dim width As Long 
    Dim ws As Worksheet 
    Dim telList As Object 
    Dim count As Long 
    Dim numList As Object 
    Set telList = CreateObject("Scripting.Dictionary") 
    Set numList = CreateObject("Scripting.Dictionary") 


    ' search for all tel/number list on other sheets 
    ' Assuming header means Row 1 
    For Each ws In Worksheets 
     If ws.Name <> Me.Name Then 
      With ws 
       .Activate 
       width = .Cells(1, .Columns.count).End(xlToLeft).Column 
       For i = 1 To width 
        If Trim(.Cells(1, i).Value) = "Tel" Then 
         Height = .Cells(.Rows.count, i).End(xlUp).Row 
         If Height > 1 Then 
          For j = 2 To Height 
           If Not telList.exists(.Cells(j, i).Value) Then 
            telList.Add .Cells(j, i).Value, "" 
           End If 
          Next j 
         End If 
        End If 
        If Trim(.Cells(1, i).Value) = "Number" Then 
         Height = .Cells(.Rows.count, i).End(xlUp).Row 
         If Height > 1 Then 
          For j = 2 To Height 
           If Not numList.exists(.Cells(j, i).Value) Then 
            numList.Add .Cells(j, i).Value, "" 
           End If 
          Next j 
         End If 
        End If 
       Next 
      End With 
     End If 

    Next 

    ' paste the tel/number list found back to this sheet 
    With Me 
     .Activate 
     width = .Cells(1, .Columns.count).End(xlToLeft).Column 
     For i = 1 To width 
      If Trim(.Cells(1, i).Value) = "Tel" Then 
       Height = .Cells(.Rows.count, i).End(xlUp).Row 
       count = 0 
       For Each tel In telList 
        count = count + 1 
        .Cells(Height + count, i).Value = tel 
       Next 
      End If 
      If Trim(.Cells(1, i).Value) = "Number" Then 
       Height = .Cells(.Rows.count, i).End(xlUp).Row 
       count = 0 
       For Each tel In telList 
        count = count + 1 
        .Cells(Height + count, i).Value = tel 
       Next 
      End If 
     Next 
    End With 

End Sub