根据第一行的值选择列并将这些列复制到另一个工作表

Question

十多年前我上过几节VBA课。从那时起，它发生了一些变化，我完全忘记了如何做甚至是基本的东西。

我在大学有一个项目，我想用Excel 2016/2017使用VBA自动化一个过程。

我从一个应用程序中得到一个巨大的Excel表。从这些列中，我只需要基于列名的几个列，我想选择我感兴趣的那些，并删除那些不感兴趣的。

我想到了几种实现它的方法:

1. 用循环搜索所有列并将它们复制到新工作表
2. 请删除我不感兴趣的列。

我尝试了if和case语句的不同选项，但我的"VBA语法";知识是可怕的。有人有什么建议吗?

表的例子:

<表类>BCDEtbody><<tr>客户产品年龄数据颜色约翰是3x蓝色

导出列到另一个工作表

• 它将创建一个工作表的副本并删除不需要的列。
• 调整常量部分的值

Option Explicit
Sub ExportColumnsToWorksheet()

' Source
Const sName As String = "Sheet1"
' Destination
Const dName As String = "NewSheet"
Const dColumnTitlesList As String = "Customer,Product,Color"

' Create a reference to the workbook containing this code ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook

' Create a reference to the Source Worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)

Application.ScreenUpdating = False

' (Attempt to) create a reference to the Destination Worksheet ('dws').
Dim dws As Worksheet
On Error Resume Next
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If Not dws Is Nothing Then ' if it exists...
Application.DisplayAlerts = False ' (without confirmation)
dws.Delete ' ... delete it
Application.DisplayAlerts = True
End If

' Copy the worksheet as the last sheet. The copy becomes the active sheet.
sws.Copy After:=wb.Sheets(wb.Sheets.Count)

' Create a reference to the copied worksheet i.e. the Destination Worksheet.
Set dws = ActiveSheet
' Give it a name.
dws.Name = dName

' Create a reference to the Destination Header Range
' (you may need a different way).
Dim dhrg As Range: Set dhrg = dws.Range("A1").CurrentRegion.Rows(1)

' Write the column titles to the Column Titles Array ('dColumnTitles').
Dim dColumnTitles() As String: dColumnTitles = Split(dColumnTitlesList, ",")

Dim delrg As Range
Dim dhCell As Range
' Loop through the cells ('dhCell') of the Destination Header Range.
For Each dhCell In dhrg.Cells
' Check if the value of the current Header Cell is not found
' in the Column Titles Array.
If IsError(Application.Match(CStr(dhCell.Value), dColumnTitles, 0)) Then
' Combine the current Header Cell into the Delete Range ('delrg').
If delrg Is Nothing Then
Set delrg = dhCell
Else
Set delrg = Union(delrg, dhCell)
End If
End If
Next dhCell

' Check if no cells were combined.
If delrg Is Nothing Then Exit Sub

' Delete the entire columns of the Delete Range.
delrg.EntireColumn.Delete

Application.ScreenUpdating = True

MsgBox "The worksheet with the desired columns has been created.", _
vbInformation, "Export Columns to Worksheet"

End Sub