Question

第一次来这里，所以对我好一点:) 只是在工作项目上使用VBA几个月，我发现我可以用google搜索的东西碰到了墙，想知道我在这里发布问题。

我有一个按钮，它将打开源工作簿并将特定范围的单元格从源工作簿复制到目标工作簿。要复制的单元格范围由for循环确定，该循环从第2行开始并循环到数据的最后一行。我让此代码在另一个项目中工作，但是当它针对另一个工作簿时，它似乎不想运行。感谢帮助，欢迎对代码提出任何建议：）

Private Sub CommandButton1_Click()

Dim lastRow, i, erow As Integer
Dim filename As String
Dim fname As Variant
Dim dwbk, swbk As Workbook
Dim sws, dws As Worksheet
Dim r1 As Range

    Set dwbk = ThisWorkbook
    Set dws = dwbk.Sheets("Call OFF")

    'On Error GoTo ErrHandling

    'Application.ScreenUpdating = False

    FileArray = Application.GetOpenFilename(Title:="Select file(s)", MultiSelect:=True)

            For Each fname In FileArray

                Set swbk = Workbooks.Open(fname)
                Set sws = swbk.Sheets("Allocations")
                lastRow = sws.Range("A" & Rows.Count).End(xlUp).Row

                For i = 2 To lastRow

                    Range(Cells(i, "A"), Cells(i, "B")).Select
                    Selection.Copy

                    dwbk.Sheets("CALL OFF").Activate
                    erow = Worksheets("CALL OFF").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
                    Worksheets("CALL OFF").Cells(erow, 2).PasteSpecial xlPasteValues

                    swbk.Activate

                Next i
            Next

    'Application.ScreenUpdating = True
'        End If

'Done:
'    Exit Sub
'
'ErrHandling:
'            MsgBox "No file selected"

End Sub

谢谢。

Answer 1

您未在复制范围上指定父级。

Range(Cells(i, "A"), Cells(i, "B")).Select

更改为：

sws.Range(sws.Cells(i, "A"), sws.Cells(i, "B")).Copy

并删除Selection.Copy行

但是您可以加快速度，并通过直接分配值来消除循环：

Private Sub CommandButton1_Click()

Dim lastRow As Long, erow As Long
Dim filename As String
Dim fname As Variant
Dim dwbk As Workbook, swbk As Workbook
Dim sws As Worksheet, dws As Worksheet
Dim r1 As Range

    Set dwbk = ThisWorkbook
    Set dws = dwbk.Sheets("Call OFF")

    'On Error GoTo ErrHandling

    'Application.ScreenUpdating = False

    FileArray = Application.GetOpenFilename(Title:="Select file(s)", MultiSelect:=True)

    For Each fname In FileArray

        Set swbk = Workbooks.Open(fname)
        Set sws = swbk.Sheets("Allocations")
        lastRow = sws.Range("A" & Rows.Count).End(xlUp).Row

        erow = dws.Cells(dws.Rows.Count, 2).End(xlUp).Offset(1, 0).Row
        dws.Cells(erow, 2).Resize(lastRow - 1, 2).Value = sws.Range(sws.Cells(2, 1), sws.Cells(lastRow, 2)).Value
    Next fname




    'Application.ScreenUpdating = True
'        End If

'Done:
'    Exit Sub
'
'ErrHandling:
'            MsgBox "No file selected"

End Sub

尝试从另一本工作簿中提取特定范围的单元格

1 个答案: