按特定顺序复制指定的列

Sub Macro1()
'
' Macro1 Macro
'
'
   Sheet4.Select
    Application.ScreenUpdating = False
    
    row_count = 2
    
    Do While Sheet2.Range("A" & row_count) <> ""
 
    Range("AX2:AX1000").Select
    Selection.Copy
    
    ActiveWindow.ActivateNext
    Range("A").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    ActiveWindow.ActivateNext
    Range("BW2:BW1000").Select
    Application.CutCopyMode = False
    Selection.Copy
    
    ActiveWindow.ActivateNext
    Range("B").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    x = x + 1
    
    ActiveWindow.ActivateNext
    ActiveSheet.Next.Select
    
    ActiveSheet.Next.Select
       
    Loop
    
End Sub

我希望我没有走得太远。试试这个下标，它会要求您选择一个工作簿，它将打开工作簿，将 B2 列复制到 B 列上上次使用的行，然后将其粘贴到第一个工作簿上。确保在代码上重命名 CopyFromSheet 和 CopyToSheet。请阅读每一行并尝试了解它在做什么。如果有任何问题，请告诉我。

Sub CopyPaste()
    Dim openFile As FileDialog, wb As Workbook, sourceWb As Workbook
    Dim CopyTo As String, CopyFrom As String
    Dim lastRow As Long
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    Set openFile = Application.FileDialog(msoFileDialogFilePicker)
    openFile.Title = "Select Source File"
    openFile.Filters.Clear
    openFile.Filters.Add "Excel Files Only", "*.xl*"
    openFile.Filters.Add "All Files", "*.*"
    openFile.Show
    If openFile.SelectedItems.Count <> 0 Then
        Set sourceWb = Workbooks.Open(openFile.SelectedItems(1), False, True, , , , True)
        CopyFrom = "CopyFromSheetName"
        CopyTo = "CopyToSheetName"
        lastRow = sourceWb.Sheets(CopyFrom).Cells(Rows.Count, "B").End(Excel.xlUp).Row
        sourceWb.Sheets(CopyFrom).Range("B2:B" & lastRow).Copy 'You can copy this Row and the Next and add as many as you want to copy the Columns Needed
        wb.Sheets(CopyTo).Range("B1").PasteSpecial xlValues
        Application.CutCopyMode = xlCopy
    Else
        MsgBox "A file was not selected"
    End If
    Application.ScreenUpdating = True
End Sub

我建议您将复制逻辑与要复制的列的设置分开。 这样管理设置就会容易得多。

在此代码中，我已硬编码为列对。 或者，您可以将该数据放在工作表上并读取它。

Sub Demo()
    'declare all your variables
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim rSource As Range
    Dim rDest As Range
    Dim CP() As Variant 'Column Pairs array
    Dim idx As Long
    'Set up an array of Source and Destination columns
    ReDim CP(1 To 21, 1 To 2) 'Adjust size to suit number of column pairs
    CP(1, 1) = "AX": CP(1, 2) = "A"
    CP(2, 1) = "BW": CP(2, 2) = "B"
    'and so on
    ' Source and Destination don't have to be in the same Workbook
    ' This code assumes the Source (and Destination) worksbooks are already open
    '    You can add code to open them if required
    ' If the data is in the same book as the code, use ThisWorkbook
    ' If the data is in a different book from the code,
    '    specify the book like Application.Workbooks("BookName.xlsx")
    '    or use ActiveWorkbook
    'Update the names to your sheet names
    Set wsSource = ThisWorkbook.Worksheets("SourceSheetName")
    Set wsDest = ThisWorkbook.Worksheets("DestSheetName")

    ' Notice that form here on the code is independent of the Sheet and Column names
    'Loop the column pairs array
    For idx = 1 To UBound(CP, 1)
        'if the entry is not blank
        If CP(idx, 1) <> vbNullString Then
            'Get reference to source column cell on row 2
            Set rSource = wsSource.Columns(CP(idx, 1)).Cells(2, 1)
            'If that cell is not empty
            If Not IsEmpty(rSource) Then
                'If the next cell is not empty
                If Not IsEmpty(rSource.Offset(1, 0)) Then
                    'extend range down to first blank cell
                    Set rSource = wsSource.Range(rSource, rSource.End(xlDown))
                End If
                'Get a reference to the destination range, from row 2, same size as source
                Set rDest = wsDest.Columns(CP(idx, 2)).Cells(2, 1).Resize(rSource.Rows.Count)
                'Copy the values
                rDest.Value = rSource.Value
            End If
        End If
    Next
End Sub