Question

我目前正在开发一个从不同工作簿中的另一个Excel工作表中提取数据的宏，该宏将让用户选择哪个工作簿以及哪些工作表用户想要复制数据，但现在我收到错误消息

自动化错误

在

行

Set RngToPaste = Union(wSheet2.Range("AD" & (X)), wSheet2.Range("AD" & X))

我不确定为什么会导致错误，导致当我使用此行从同一工作簿中提取数据时，它可以正常工作。

供您参考，其余代码在此处：

Sub CopyFourColumns()
   '// Declare your variables.
    Dim wSheet1 As Worksheet
    Dim wSheet2 As Worksheet
    Dim wSlastRow As Long
    Dim X As Long
    Dim RngToCopy As Range
    Dim RngToPaste As Range
    Dim wkbSourceBook As Workbook
    Dim wkbCrntWorkBook As Workbook

    Set wkbCrntWorkBook = ActiveWorkbook
    '// Set here Workbook(Sheets) names
    With wkbCrntWorkBook
        Set wSheet2 = ActiveSheet
    End With

    'extract data from another excel file
    With Application.FileDialog(msoFileDialogOpen)
    .Filters.Clear
    .Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count > 0 Then
        Workbooks.Open .SelectedItems(1)
        Set wkbSourceBook = ActiveWorkbook
        Set wSheet1 = ActiveSheet

        '// Here lets Find the last row of data
        wSlastRow = wSheet1.Range("AD" & Rows.Count).End(xlUp).Row
        wSlastRow = wSheet1.Range("AF" & Rows.Count).End(xlUp).Row
        wSlastRow = wSheet1.Range("AH" & Rows.Count).End(xlUp).Row
        wSlastRow = wSheet1.Range("AE" & Rows.Count).End(xlUp).Row

    '// Now Loop through each row
    For X = 2 To wSlastRow

        'insert wSlastRow no of rows to worksheet Summary
        Rows(wSlastRow).Insert Shift:=xlDown
        'Set RngToPaste = wSheet2.Range("P" & (X + 1))
        Set RngToPaste = Union(wSheet2.Range("AD" & (X)), wSheet2.Range("AD" & X))
        With wSheet1
            'Set RngToCopy = Union(.Range("P" & X), .Range("P" & X))
            Set RngToCopy = Union(.Range("P" & (X)), .Range("P" & X))
            RngToCopy.Copy RngToPaste
        End With

        Set RngToPaste = Union(wSheet2.Range("AF" & (X)), wSheet2.Range("AF" & X))
        With wSheet1
            Set RngToCopy = Union(.Range("W" & (X)), .Range("W" & X))
            RngToCopy.Copy RngToPaste
        End With

        Set RngToPaste = Union(wSheet2.Range("AH" & (X)), wSheet2.Range("AH" & X))
        With wSheet1
            Set RngToCopy = Union(.Range("C" & (X)), .Range("C" & X))
            RngToCopy.Copy RngToPaste
        End With

        Set RngToPaste = Union(wSheet2.Range("AI" & (X)), wSheet2.Range("AI" & X))
        With wSheet1
            Set RngToCopy = Union(.Range("R" & (X)), .Range("R" & X))
            RngToCopy.Copy RngToPaste
        End With
        'Add Schedule value
        Set RngToPaste = Union(wSheet2.Range("AE" & (X)), wSheet2.Range("AE" & X))
            RngToPaste.Value = "Scheduled"
        'Add Emaill address value
        Set RngToPaste = Union(wSheet2.Range("U" & (X)), wSheet2.Range("U" & X))
            RngToPaste.Value = ".com"
        Set RngToPaste = Union(wSheet2.Range("V" & (X)), wSheet2.Range("V" & X))
            RngToPaste.Value = ".com"
        Set RngToPaste = Union(wSheet2.Range("AA" & (X)), wSheet2.Range("AA" & X))
            RngToPaste.Value = ".com"
        Set RngToPaste = Union(wSheet2.Range("AB" & (X)), wSheet2.Range("AB" & X))
            RngToPaste.Value = ".com"
        Set RngToPaste = Union(wSheet2.Range("AC" & (X)), wSheet2.Range("AC" & X))
            RngToPaste.Value = ".com"
    Next X

        wkbSourceBook.Close False
    End If
    End With

    '// Simple Msg Box
    MsgBox "Copy & Paste is Done."
End Sub

以下是示例数据： enter image description here

Answer 1

我帮助您改进代码，没有必要使用这么多

Set RngToPaste = Union(wSheet2.Range("AD" & (X)), wSheet2.Range("AD" & X))

不知何故，我只是不确定为什么你计算4列的最后一行值并在同一个变量中分配？

wSlastRow = wSheet1.Range("AD" & Rows.Count).End(xlUp).Row
wSlastRow = wSheet1.Range("AF" & Rows.Count).End(xlUp).Row
wSlastRow = wSheet1.Range("AH" & Rows.Count).End(xlUp).Row
wSlastRow = wSheet1.Range("AE" & Rows.Count).End(xlUp).Row

以下是我从您的代码中增强的代码：

Option Explicit
Dim CurrentWorkbook As Workbook
Dim DataWorkbook As Workbook
Dim CurrentWorksheet As Worksheet
Dim DataWorksheet As Worksheet


Sub CopyFourColumns()
'// Declare your variables.
Set CurrentWorkbook = ActiveWorkbook
Set CurrentWorksheet = CurrentWorkbook.ActiveSheet

Dim CurrentRowPointer As Long

'extract data from another excel file
With Application.FileDialog(msoFileDialogOpen)
    .Filters.Clear
    .Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
    .AllowMultiSelect = False
    .Show

    If .SelectedItems.Count > 0 Then
        Workbooks.Open .SelectedItems(1)
        Set DataWorkbook = ActiveWorkbook
        Set DataWorksheet = DataWorkbook.ActiveSheet

        '// Here lets Find the last row of data
        'wSlastRow = DataWorksheet.Range("AD" & Rows.Count).End(xlUp).row
        'wSlastRow = wSheet1.Range("AF" & Rows.Count).End(xlUp).row
        'wSlastRow = wSheet1.Range("AH" & Rows.Count).End(xlUp).row
        'wSlastRow = wSheet1.Range("AE" & Rows.Count).End(xlUp).row

    '// Now Loop through each row
    For CurrentRowPointer = 2 To DataWorksheet.Range("AD" & Rows.Count).End(xlUp).row

        'insert wSlastRow no of rows to worksheet Summary
        DataWorksheet.Rows(DataWorksheet.Range("AD" & Rows.Count).End(xlUp).row).Insert Shift:=xlDown
        CurrentWorksheet.Range("P" & CurrentRowPointer).Value = DataWorksheet.Range("AD" & CurrentRowPointer).Value
        CurrentWorksheet.Range("W" & CurrentRowPointer).Value = DataWorksheet.Range("AF" & CurrentRowPointer).Value
        CurrentWorksheet.Range("C" & CurrentRowPointer).Value = DataWorksheet.Range("AH" & CurrentRowPointer).Value
        CurrentWorksheet.Range("R" & CurrentRowPointer).Value = DataWorksheet.Range("AI" & CurrentRowPointer).Value

        'Add Schedule value
        DataWorksheet.Range("AE" & CurrentRowPointer).Value = "Scheduled"

        'Add Emaill address value
        DataWorksheet.Range("U" & CurrentRowPointer).Value = ".com"
        DataWorksheet.Range("V" & CurrentRowPointer).Value = ".com"
        DataWorksheet.Range("AA" & CurrentRowPointer).Value = ".com"
        DataWorksheet.Range("AB" & CurrentRowPointer).Value = ".com"
        DataWorksheet.Range("AC" & CurrentRowPointer).Value = ".com"

    Next X

    DataWorkbook.Close False
    End If
End With

'// Simple Msg Box
MsgBox "Copy & Paste is Done."

End Sub

Answer 2

当您使用Set ... = ...的对象时，请不要忘记在代码末尾使用Set ... = Nothing释放引用。

如果您对代码量或其他方面不感兴趣，那么您不必非常使用对象。（特别是副本）

您的代码已经过清理和审核，请尝试一下：

Sub CopyFourColumns()
'// Declare your variables.
Dim wSheet1 As Worksheet, _
    wSheet2 As Worksheet, _
    wSlastRow As Long, _
    X As Long, _
    wkbSourceBook As Workbook, _
    wkbCrntWorkBook As Workbook

Set wkbCrntWorkBook = ActiveWorkbook
'// Set here Workbook(Sheets) names
Set wSheet2 = wkbCrntWorkBook.ActiveSheet

'extract data from another excel file
With Application.FileDialog(msoFileDialogOpen)
    .Filters.Clear
    .Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count > 0 Then
        Set wkbSourceBook = Workbooks.Open(.SelectedItems(1))
        Set wSheet1 = wkbSourceBook.ActiveSheet

        '// Here lets Find the last row of data
        wSlastRow = wSheet1.Rows(wSheet1.Rows.Count).End(xlUp).Row

        '// Now Loop through each row
        For X = 2 To wSlastRow
            'insert wSlastRow no of rows to worksheet Summary
            wSheet1.Rows(wSlastRow).Insert Shift:=xlDown

            wSheet1.Range("P" & X).Copy Destination:=wSheet2.Range("AD" & X)
            wSheet1.Range("W" & X).Copy Destination:=wSheet2.Range("AF" & X)
            wSheet1.Range("C" & X).Copy Destination:=wSheet2.Range("AH" & X)
            wSheet1.Range("R" & X).Copy Destination:=wSheet2.Range("AI" & X)

            'Add Schedule value
            wSheet2.Range("AE" & X).Value = "Scheduled"

            'Add Emaill address value
            wSheet2.Range("U" & X).Value = ".com"
            wSheet2.Range("V" & X).Value = ".com"
            wSheet2.Range("AA" & X).Value = ".com"
            wSheet2.Range("AB" & X).Value = ".com"
            wSheet2.Range("AC" & X).Value = ".com"
        Next X

        wkbSourceBook.Close False
    End If
End With

'Free objects
Set wkbCrntWorkBook = Nothing
Set wSheet2 = Nothing
Set wkbSourceBook = Nothing
Set wSheet1 = Nothing

'// Simple Msg Box
MsgBox "Copy & Paste is Done."
End Sub

从另一个Excel文件中提取数据时出现自动化错误

2 个答案: