1

我可以根据列号将选定的列从一个工作表复制到另一个工作表。但是有一天我可能会决定在源文件的中间某处添加一列。如果我根据列名复制列，这将不是问题。以下是我的代码。注释部分是根据列号完成实际复制的地方，我希望将其替换为列标签。列标签让我们说是Price Number、House Price和：AddressCost

  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
4

2 回答 2

0 
 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

有一些注释可以帮助您了解代码的工作原理。尝试根据您的要求进行修改

于 2014-02-03T07:30:03.333 回答
0

逻辑：

用于.Find查找列标题，然后使用该列号进行复制。下面是一个示例，它将复制有说的列Joseph Jaajaa

好读：

Excel VBA中的.Find和.FindNext

假设：

我假设标题在第 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

截屏

在此处输入图像描述

于 2013-08-07T11:30:50.750 回答