搜索特定的列标题名称，复制列和粘贴以附加到另一个wookbooksheet [英] Search for specific column header names, copy columns and paste to append to another 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 names and 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的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！