搜索特定的列标题名称，复制列和粘贴以附加到另一个wookbooksheet

问题描述

我的工作簿有一张，两张或三张。
每张表可以包含以下列标题名称中的至少一个：电话或数字。

My workbook has one,two or three sheets.Each sheet can contain at least one of these column header names: "Tel" or "Number".

如何使用这些列标题名
复制整个列（仅数据），然后将其粘贴（只需一列即可添加相同的列标题名称）转换为VBA代码（Sheet Module）所在的另一个工作簿。谢谢。

How can I copy the entire columns ( data only) with these column header namesand paste them (as an append in just one column with the same column header name) into another workbook sheet where the VBA code ( Sheet Module) is. Thanks.

推荐答案

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

这篇关于搜索特定的列标题名称，复制列和粘贴以附加到另一个wookbooksheet的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！