VBA to copy / paste then save each row as new workbook

[merquiaga]

Hi all,

I am trying to get a macro for an extremely repetitive task to copy a row onto another sheet, save the workbook as column A + space + D + Space + B then go onto the next row and so on.

1. Copy row 2 from "Paste" sheet (Data is from column A to AN)
2. Paste onto row 2 on another sheet called "Template"
3. Then save the whole workbook (not just the sheet) as macro enabled and name it column A + space + D + Space + B
4. Then it can refilter to the next row...

What I have so far is missing 1 & 2 and then doesn't save the whole workbook and names it column A only. Help!

Dim sh As Worksheet, lr As Long, rng As Range, eRng As Range, c As Range, wb As Workbook
Set sh = Sheets("Paste") 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("A2:A" & lr)
sh.Columns("AP").Insert
rng.AdvancedFilter xlFilterCopy, , sh.Range("AP2"), Unique:=True
Set eRng = sh.Range("AP2", sh.Cells(Rows.Count, 42).End(xlUp))
    For Each c In eRng
        Set wb = Workbooks.Add
        sh.Range("A1:AN1").Copy wb.Sheets(1).Range("A1")
        sh.Range("A2:A" & lr).AutoFilter 1, c.Value
        rng.SpecialCells(xlCellTypeVisible).EntireRow.Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2)
        wb.SaveAs ThisWorkbook.Path & "\" & c.Value
        sh.AutoFilterMode = False
wb.Close False
Set wb = Nothing
    Next
sh.Columns("AP").Delete
End Sub

 

[DanteAmor]

1. Copy row 2 from "Paste" sheet (Data is from column A to AN)
2. Paste onto row 2 on another sheet called "Template"
3. Then save the whole workbook (not just the sheet) as macro enabled and name it column A + space + D + Space + B
4. Then it can refilter to the next row...

Your prompts say copy row 2.
But your macro filters the sheet with the values in column A.
What do you really need?

 

[DanteAmor]

Following your instructions, it would be something like this:

Sub copyrows()
  Dim i As Long
  With Sheets("Paste")
    For i = 2 To .Range("A" & Rows.Count).End(3).Row
      .Rows(i).Copy Sheets("Template").Range("A2")
      ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & .Range("A" & i) & " " & .Range("D" & i) & " " & .Range("B" & i) & ".xlsm"
    Next
  End With
End Sub

 

[merquiaga]

Oh my gosh you're amazing!! It works the only thing is it doesn't stop so how do we put in there if the row is empty to stop?

Thank you SO much!

 

[merquiaga]

Following your instructions, it would be something like this:

Sub copyrows()
  Dim i As Long
  With Sheets("Paste")
    For i = 2 To .Range("A" & Rows.Count).End(3).Row
      .Rows(i).Copy Sheets("Template").Range("A2")
      ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & .Range("A" & i) & " " & .Range("D" & i) & " " & .Range("B" & i) & ".xlsm"
    Next
  End With
End Sub

Oh my gosh you're amazing!! It works the only thing is it doesn't stop so how do we put in there if the row is empty to stop?

Thank you SO much!

 

[DanteAmor]

the only thing is it doesn't stop so how do we put in there if the row is empty to stop?

Try this:

Sub copyrows()
  Dim i As Long
  With Sheets("Paste")
    For i = 2 To .Range("A" & Rows.Count).End(3).Row
      If WorksheetFunction.Trim(.Range("A" & i).Value) = "" Then Exit Sub
      .Rows(i).Copy Sheets("Template").Range("A2")
      ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & .Range("A" & i) & " " & .Range("D" & i) & " " & .Range("B" & i) & ".xlsm"
    Next
  End With
End Sub

 

[merquiaga]

Try this:

Sub copyrows()
  Dim i As Long
  With Sheets("Paste")
    For i = 2 To .Range("A" & Rows.Count).End(3).Row
      If WorksheetFunction.Trim(.Range("A" & i).Value) = "" Then Exit Sub
      .Rows(i).Copy Sheets("Template").Range("A2")
      ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & .Range("A" & i) & " " & .Range("D" & i) & " " & .Range("B" & i) & ".xlsm"
    Next
  End With
End Sub

You are my HERO!!!! Thank you so so much!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[Mimosa]

Try this:

Sub copyrows()
  Dim i As Long
  With Sheets("Paste")
    For i = 2 To .Range("A" & Rows.Count).End(3).Row
      If WorksheetFunction.Trim(.Range("A" & i).Value) = "" Then Exit Sub
      .Rows(i).Copy Sheets("Template").Range("A2")
      ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & .Range("A" & i) & " " & .Range("D" & i) & " " & .Range("B" & i) & ".xlsm"
    Next
  End With
End Sub

Hey! I had similiar task as the OP, so I used your formula and it worked flawlessly. But then there was this one issue that I didn't manage to solve. I need to export is as XML. Manually it's all ok, but I all online commands for exporting always report some flaw in the code. Would you know how to deal with this? I can provide more info if needed.