![](/img/trans.png)
[英]Search for specific column header, copy column and paste to another workbook
[英]Search for specific column header names, copy columns and paste to append to another wookbooksheet
我的工作簿有一页,两页或三页。 每张纸可以包含以下列标题名称中的至少一个:“电话”或“数字”。
我如何复制具有这些列标题名称的整个列(仅数据)并将它们(作为追加添加到具有相同列标题名称的一列中)粘贴到VBA代码(工作表模块)所在的另一工作簿工作表中。 谢谢。
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.