Question

我正在尝试创建一个循环来逐个复制源工作表中的单元格中的数据并粘贴到目标工作表中的特定单元格中。粘贴单元格后，我需要它来保存文件的副本，然后将下一个值粘贴到源工作表中。代码为：

Private Sub CommandButton1_Click()
    Dim wbTarget As Worksheet
    Dim wbSource As Worksheet
    Dim SaveLoc As String
    Dim FName As String
    Dim i As Long

    Set wbSource = Sheets("Sheet3")
    Set wbTarget = Sheets("Sheet1")

    wbSource.Activate

    Range("A1").Activate

    Do While ActiveCell.Value <> ""        
        DoEvents
        ActiveCell.Copy

        For i = 1 To 30
            wbTarget.Activate

            With ActiveSheet
                wbTarget.Range("E5").Select
                Selection.PasteSpecial Paste:=xlPasteColumnWidths
                Selection.PasteSpecial Paste:=xlPasteValues
                ThisWorkbook.Save
                Application.CutCopyMode = False
            End With

            SaveLoc = "H:\Services\Test Output\Term_"
            FName = Range("B5")
            ActiveWorkbook.SaveCopyAs FileName:=SaveLoc & FName & ".xls" 'FileFormat:=xlNormal
            Application.DisplayAlerts = False
        Next i

        wbSource.Select
        ActiveCell.Offset(1, 0).Activate
    Loop

    Application.ScreenUpdating = True
End Sub

当我运行时，我得到了一个

运行时错误1004.

请告知如何解决此问题提前谢谢。

Answer 1

尝试以下代码，不使用Activate，ActiveCell，Select和Selection，而是使用完全符合条件的Range和Worksheet对象。

代码中的注释作为注释（也是关于代码的一些问题）。

<强> 代码

Option Explicit

Private Sub CommandButton1_Click()

    Dim wbTarget As Worksheet
    Dim wbSource As Worksheet
    Dim SaveLoc As String
    Dim FName As String
    Dim i As Long, lRow As Long

    Set wbSource = Sheets("Sheet3")
    Set wbTarget = Sheets("Sheet1")

    ' SaveLoc string never changes, doesn;t need to be set every time inside the loops
    SaveLoc = "H:\Services\Test Output\Term_"

    ' you never qualifed the range with on of the worksheets (I'm guessing here it's "Sheet3"
    FName = wbTarget.Range("B5").Value

    Application.ScreenUpdating = False
    lRow = 1
    Do While wbSource.Range("A" & lRow).Value <> ""
        wbSource.Range("A" & lRow).Copy
        For i = 1 To 30
            ' 2 lines below you are pasting to cell "E5" don't you mean to increment with the row number (i variable)
            wbTarget.Range("E5").PasteSpecial xlPasteValues
            wbTarget.Range("E5").PasteSpecial xlPasteColumnWidths

            ThisWorkbook.Save
            Application.CutCopyMode = False

            ' have this line before trying to save a copy of this workbook
            Application.DisplayAlerts = False
            ThisWorkbook.SaveCopyAs Filename:=SaveLoc & FName & ".xls"  'FileFormat:=xlNormal
            Application.DisplayAlerts = True
        Next i
        lRow = lRow + 1
    Loop
    Application.ScreenUpdating = True

End Sub

粘贴特殊错误 - 1004 VBA Excel

1 个答案: