VBA Copy and Paste Column based of Column Heading

问题

I hope you can help. What I am trying to achieve is this: I want the VBA to search through column headings to find a heading that contains the text "CountryCode" once it finds this I want it to cut this column and paste it into the sixth column. My attempt at code is below but it not working correctly I have attached screen shots for better understanding.

I know Destination:=Worksheets("Sheet1").Range("E5")is wrong I just cant seen to get it to paste into the newly created F Column

Screen Shot: Country Code was in Column W I just cant get it to paste into the new F column. Any help would be greatly appreciated.

Sub Sample()
    Dim ws As Worksheet
    Dim aCell As Range, Rng As Range
    Dim col As Long, lRow As Long
    Dim colName As String

    '~~> Change this to the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        Set aCell = .Range("A1:X50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _
                    MatchCase:=False, SearchFormat:=False)
    '~~> If Found
    If Not aCell Is Nothing Then
    Worksheets("Sheet1").Range("W1:W3").Cut _
            Destination:=Worksheets("Sheet1").Range("E5")
            Columns([23]).EntireColumn.Delete
            Columns("F:F").Insert Shift:=xlToRight, _
    CopyOrigin:=xlFormatFromLeftOrAbove
    '~~> If not found
    Else
            MsgBox "Country Not Found"
        End If
    End With
End Sub

回答1:

Does this code do what you are looking for?

Sub Sample()
    Dim ws As Worksheet
    Dim aCell As Range, Rng As Range
    Dim col As Long, lRow As Long
    Dim colName As String

    '~~> Change this to the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        Set aCell = .Range("A1:X50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _
                    MatchCase:=False, SearchFormat:=False)
    '~~> If Found
    If Not aCell Is Nothing Then

    '~~> Cut the entire column
    aCell.EntireColumn.Cut

    '~~> Insert the column here
    Columns("F:F").Insert Shift:=xlToRight

    Else
    MsgBox "Country Not Found"

    End If
    End With
End Sub

回答2:

There is no need to use Delete or Insert. Range().Cut Destination:=Range() will move the cells into position for you.

Sub Sample()
    Dim aCell As Range

    With ThisWorkbook.Sheets("Sheet1")
        Set aCell = .Rows(1).Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _
                                          MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            aCell.EntireColumn.Cut Destination:=.Columns(5)
        Else
            MsgBox "Country Not Found"
        End If
    End With
End Sub

来源：https://stackoverflow.com/questions/39894035/vba-copy-and-paste-column-based-of-column-heading