1

列番号に基づいて、選択した列をあるワークシートから別のワークシートにコピーできます。しかし、ある日、ソース ファイルの途中に列を追加することにするかもしれません。列名に基づいて列をコピーすると、これは問題になりません。以下は私が持っているコードです。コメント部分は、列番号に基づいて実際のコピーが行われる場所で、列ラベルに置き換えようとしています。列ラベルは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
4

2 に答える 2

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 に答える
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 に答える