1
votes

I am trying to create a loop to copy data in cells in source worksheet one by one and paste in a particular cell in target worksheet. Once the cell is pasted, i need it to save a copy of the file then paste the next value in the source worksheet.The code is:

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

When I run this, I get a

run-time error 1004.

Please advise on how to resolve this.
Thank You in Advance.

1
See this, there could be many reasons ... stackoverflow.com/questions/17980854/…Paul T.

1 Answers

1
votes

Try the code below, without using Activate, ActiveCell, Select and Selection, instead use fully qualifies Ranges and Worksheet objects.

Explanation inside the code as comments (also some question about your code).

Code

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