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

merquiaga

New Member
Joined
Jul 12, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
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!

VBA Code:
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
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,993
Office Version
  1. 2007
Platform
  1. Windows
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

Well-known Member
Joined
Dec 3, 2018
Messages
13,993
Office Version
  1. 2007
Platform
  1. Windows
Following your instructions, it would be something like this:

VBA Code:
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

New Member
Joined
Jul 12, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
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

New Member
Joined
Jul 12, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Following your instructions, it would be something like this:

VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
13,993
Office Version
  1. 2007
Platform
  1. Windows
the only thing is it doesn't stop so how do we put in there if the row is empty to stop?
Try this:

VBA Code:
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
 
Solution

merquiaga

New Member
Joined
Jul 12, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Try this:

VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
13,993
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Forum statistics

Threads
1,148,364
Messages
5,746,272
Members
424,002
Latest member
anon341

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top