使用列标签NOT数字复制多个列

我可以根据列号将选定的列从一个工作表复制到另一个工作表。 但是有一天，我可能会决定在源文件中添加一个列。 如果我根据列名称复制列，这不会是一个问题。 以下是我的代码。 注释部分是根据列号完成实际复制的位置，我正在用列标签取代。 列标签我们只是说Price Number ， House Price ， Address和Cost ：

  Sub CommercialView() Dim wrkbk, sourceBk As Workbook Set sourceBk = Application.ActiveWorkbook 'Clear Filter for all Columns START With ActiveSheet If .AutoFilterMode Then If .FilterMode Then .ShowAllData End If Else If .FilterMode Then .ShowAllData End If End If End With 'Clear Filter from all Columns END 'Copy the required columns and add them to the destination spreadsheet START Workbooks.Add Set wrkbk = Application.ActiveWorkbook sourceBk.Activate wrkbk.Activate sourceBk.Activate Range("A1,B1,C1,D1,E1,G1,H1,I1,R1,V1,W1,X1").EntireColumn.Select 'BASED ON COLUMN NO. Selection.Copy Range("A2").Select wrkbk.Activate ActiveSheet.Paste Selection.AutoFilter 'Copy the required columns and add them to the destination spreadsheet END 'To remove data validation START Cells.Select With Selection.Validation .Delete .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With 'To remove data validation END wrkbk.Activate wrkbk.Sheets("Sheet1").Select ActiveSheet.Range("$A$1:$L$4000").AutoFilter Field:=10, Criteria1:= _ "Completed - Requires Review from Pricing" 'Copy the Status Definitions tab to the new worksheet START sourceBk.Sheets("2. Status Definitions").Copy _ after:=ActiveWorkbook.Sheets("Sheet1") 'Copy the Status Definitions tab to the new worksheet END wrkbk.Sheets("Sheet1").Select Range("A5").Select ActiveWorkbook.SaveAs ("C:\Users\test\Desktop\DOD\Change Status Request Report\Commercial View\Internal Change Status Request Report - Commercial View - " & Format(Now, "yyyy-mm-dd")) ActiveWorkbook.Close End Sub 

Answer 1

逻辑 ：

使用。查找find列标题，然后使用该列号进行复制。 下面是一个例子，它将复制说Joseph Jaajaa

好阅读 ：

.Find和.FindNext在Excel VBA中

假设 ：

我假设头是在第1行

代码 ：

 Option Explicit Sub Sample() Dim ws As Worksheet Dim aCell As Range Dim strSearch As String strSearch = "Joseph Jaajaa" Set ws = ThisWorkbook.Sheets(1) With ws Set aCell = .Rows(1).Find(What:=strSearch, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Not aCell Is Nothing Then MsgBox "Value Found in Cell " & aCell.Address & vbCrLf & _ "and the column number is " & aCell.Column '~~> Do the copying here .Columns(aCell.Column).Copy Else MsgBox "Search value not found" End If End With End Sub 

截图

Answer 2

  Sub MoveColumns() Dim sh1 As Object Dim sh2 As Object Dim a, i As Integer Dim x As String Set sh1 = ThisWorkbook.Sheets(1): _ Set sh2 = ThisWorkbook.Sheets(2) 'Take all table data to array a = Range([a1], Cells(1, sh1.UsedRange.Columns.Count)) With sh1: .Activate 'Instruction to deal with error that may arise in execution process On Error GoTo handler 'Standard looping cycle based on the number of columns of the table For i = 1 To UBound(a, 2) 'Function that links digit to column header title. Header titles go in the order you need. 'So for example you put i=1, "New date" you will have it as the first column in result table 'and the code will try to find that title in the original data table x = Switch(i = 1, "Replace", i = 2, _ "These", i = 3, "with", i = 4, "", i = 5, _ "", i = 6, "your ", i = 7, "Texts", _ i = 8, "Settlement Date Contractual", i = 9, _ "Transaction Type", i = 10, "Quantity Remaining", _ i = 11, "Balhs", i = 12, "Amt Remaining Settlement Ccy", _ i = 13, "Amt Remaining Calculated USD", i = 14, _ "Cusip Code", i = 15, "Isin Code", i = 16, _ "Internal Product Description", i = 17, "Counterparty Mnemonic", _ i = 18, "Counterparty Name", i = 19, "Market Settlement Code", _ i = 20, "Age Band") 'Looking for the header and copying to a new table in the order defined by the function arguments If x <> "" Then .Columns(.Rows(1).Find(x, , , xlWhole).Column) _ .Copy sh2.Columns(i) Next: End With 'Clear up everything Set sh1 = Nothing: Set sh1 = Nothing On Error GoTo 0: Exit Sub 'What the code will do in case of error handler: 'Message box to provide the cause of error and possible actions to correct it MsgBox "Header title " & x & " is not found. Double check sheet structure or header title", vbCritical On Error GoTo 0: Exit Sub End Sub 

有评论可以帮助你理解代码是如何工作的。 尝试根据您的要求进行修改