Question

我从一个有80列左右数据的软件中导出了数据。我不需要所有数据，只需21列。

在我的输出中，我希望21列按特定顺序排列。因此，例如，我希望源文件中来自单元格AX2的值转到输出中的A2，BW2转到B2等。

每个月的源数据可能有所不同，并且可能只有1行或数百行数据，所以我希望这样循环直到没有数据剩下。

我试图编写代码，但是遇到了问题。我收到了一个运行时错误424对象。注意：我仅概述了两列的规则，但是当我进行了正确的设置后，其余的规则将起作用：

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

Answer 1

我希望我不会走得太远。尝试使用此下标，它要求您选择一个工作簿，它将打开该工作簿，将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

Answer 2

我建议您将复制逻辑与要复制的列的设置分开。这样，将更易于管理设置。

在此代码中，我已硬编码为“列对”。或者，您可以将该数据放在一张纸上并读入。

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

具有复制粘贴值问题的初学者Excel VBA

2 个答案: