excel - 基于标题的列选择和排序列位置

Question

我想根据标题复制列数据并将其粘贴到特定位置的另一张表中。我编写了一个代码，当在源表中我有我搜索的那些列标题时，它可以完美运行。

Sub Copy()
Dim myCollection(1 To 5)    As String
Dim myIterator      As Variant
Dim myRng           As Range
Dim xlcell          As Variant
Dim otherwb         As Worksheet
Dim mywb            As Workbook
Dim colCounter, i     As Integer


Application.ScreenUpdating = False

Set mywb = ThisWorkbook


'Create a collection of header names to search through

myCollection(1) = "Name"
myCollection(2) = "Age"
myCollection(3) = "Region"
myCollection(4) = "Uni"
myCollection(5) = "Grade"


'Where to search, this is the header
Set myRng = mywb.Sheets("Sheet0").Range("A1:E1")
mywb.Worksheets.Add(after:=Worksheets(1)).Name = "Sorted"
Set otherwb = mywb.Sheets("Sorted")
colCounter = 0
'For Each myCollection(i) In myCollection look in each item in the collection   
For i = LBound(myCollection) To UBound(myCollection)

' look through each cell in your header
 For Each xlcell In myRng.Cells 


 ' when the header matches what you are looking for
        If myCollection(i) = xlcell.Value Then 

        ' creating a column index for the new workbook
            colCounter = colCounter + 1 
            mywb.Sheets("Sheet0").Columns(xlcell.Column).Copy
            otherwb.Columns(colCounter).Select
            otherwb.Paste
        End If      

 Next
Next

otherwb.Range("A1:E1").AutoFilter

End Sub

我现在面临的问题是，例如，如果它在源表中找不到标题“Uni”，那么由于我设置的列计数器，它会将“等级”列放在第 4 列而不是第 5 列。因此，我的列顺序错误。

但是，我想创建带有定义列标题的排序表。因此，如果源工作表中没有“Uni”，则应将“Uni”粘贴为已排序工作表中的标题并保持列为空，然后粘贴“Grade”列。

问候，奥利弗

标签： excelvbastringcollections

Answer 1

像这样的东西：

所以基本上你会用它Rang.Find来查找列的名称，如果找到了，那么你可以将它粘贴到另一张表上，如果没有，那么它只是列标题。因此，您的序列不会受到干扰。

Sub Copy()
Dim myCollection(1 To 5)    As String
Dim myIterator      As Variant
Dim myRng           As Range
Dim xlcell          As Variant
Dim otherwb         As Worksheet
Dim mywb            As Workbook
Dim colCounter, i     As Integer


Application.ScreenUpdating = False

Set mywb = ThisWorkbook


'Create a collection of header names to search through

myCollection(1) = "Name"
myCollection(2) = "Age"
myCollection(3) = "Region"
myCollection(4) = "Uni"
myCollection(5) = "Grade"


'Where to search, this is the header
Set myRng = mywb.Sheets("Sheet0").Range("A1:E1")
mywb.Worksheets.Add(after:=Worksheets(1)).Name = "Sorted"
Set otherwb = mywb.Sheets("Sorted")
colCounter = 0
'For Each myCollection(i) In myCollection look in each item in the collection

Dim fnd As Range

For i = LBound(myCollection) To UBound(myCollection)

    Set fnd = myRng.Find(myCollection(i))

    If Not fnd Is Nothing Then

        ' creating a column index for the new workbook
            colCounter = colCounter + 1
            mywb.Sheets("Sheet0").Columns(fnd.Column).Copy
            otherwb.Columns(colCounter).Select
            otherwb.Paste
    Else
            colCounter = colCounter + 1
            otherwb.Cells(1, colCounter) = myCollection(i)

    End If

Next

otherwb.Range("A1:E1").AutoFilter

End Sub