VBA Macro to Copy/Paste Data into new Workbook & Save in New Folder

[Dotcomaphobe]

I have a spreadsheet that will have, say, 101 rows (with header) in sheet one, with data in columns A, B & C.

Sheet 2 has a table in it as well.

I need a macro that will do the following:

• Copy the data in row 2, sheet 1
• copy the entire table in sheet 2 (range A1:M27)
• Paste all of that data in a new workbook
• save the new workbook in a folder named after cell A2, with the filename "(A2 data) Review 1"
• Save a second copy in the same folder with the filename "(A2 data) Review 2"
• Repeat for each row to the end of data in column A

This is a big request. Any help would be incredible. Thanks!

 

[Dotcomaphobe]

Looking through the forum, I've found some code that AlphaFrog wrote for a poster about a year ago. I've adapted it as follows:

Sub Save_Account_Data()
    
    Dim wsSource As Worksheet, Lastrow As Long
    Dim Accounts As Range, Account As Range
    Dim wbDest As Workbook
    Dim SavePath As String, AccountFilename As String
    Dim counter As Long
    
    Application.ScreenUpdating = False
    
    Set wsSource = ActiveSheet
    With wsSource
        Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A2:A" & Lastrow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set Accounts = .Range("A2:A" & Lastrow).SpecialCells(xlCellTypeVisible)
        If .FilterMode Then .ShowAllData
        .Copy
    End With
    Set wbDest = ActiveWorkbook
    wbDest.Sheets(1).UsedRange.ClearContents
    
    
    
    For Each Account In Accounts
        wsSource.Range("A:A").AutoFilter Field:=1, Criteria1:=Account.Value
        
        SavePath = "C:\Documents and Settings\xjbh755\My Documents\Adjustment Recommendation Worksheet Project\" & Account.Value & "\"
        If Dir(SavePath, vbDirectory) = vbNullString Then MkDir SavePath
    
        wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=wbDest.Sheets(1).Range("A1")
            AccountFilename = Account.Value & "_Review 1.xlsx"
            On Error Resume Next
                wbDest.SaveAs SavePath & AccountFilename, FileFormat:=51
                    
            On Error GoTo 0
            If wbDest.Name = AccountFilename Then counter = counter + 1
            wbDest.Sheets(1).UsedRange.ClearContents
    Next Account
    
    wbDest.Close SaveChanges:=False
    wsSource.AutoFilterMode = False
    Application.ScreenUpdating = True
    
    MsgBox counter & " files saved to " & SavePath, vbInformation, "Save Account Data"
    
End Sub

This works great, and is a wonderful start, but there are a few tweaks that need to be made.

The data from Sheet 1 is copied as a row, but I need to paste it into a column. The header range A1:C1 should be pasted into the new sheet in A1:A3. The account data in A2:C2 (and all the way down) should be pasted in B1:B3.

Then the table in Sheet 2 should be pasted starting at cell C1 in the new workbook.

I'll also need to save two copies of each new workbook. The first named (Account.Value & "_Review 1.xlsx") and the second named (Account.Value & "_Review 2.xlsx"). Both should be saved in the same folder.

I'm still trying to figure it out, but if anyone has some tips, I'd sure love to hear them!

 

[Dotcomaphobe]

I've been able to figure out how to save two copies into two separate locations! I feel like I've had a breakthrough!

Sub Save_Account_Data()
    
    Dim wsSource As Worksheet, Lastrow As Long
    Dim wsSource2 As Worksheet
    Dim Accounts As Range, Account As Range
    Dim wbDest As Workbook
    Dim SavePath As String, AccountFilename As String
    Dim counter As Long
    
    Application.ScreenUpdating = False
    
    Set wsSource = ActiveSheet
    With wsSource
        Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A2:A" & Lastrow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set Accounts = .Range("A2:A" & Lastrow).SpecialCells(xlCellTypeVisible)
        If .FilterMode Then .ShowAllData
        .Copy
    End With
    Set wbDest = ActiveWorkbook
    wbDest.Sheets(1).UsedRange.ClearContents
          
    For Each Account In Accounts
        wsSource.Range("A:A").AutoFilter Field:=1, Criteria1:=Account.Value
        
        SavePath = "C:\Users\JBH\Documents\Loan Data\Review 1\" & Account.Value & "\"
        If Dir(SavePath, vbDirectory) = vbNullString Then MkDir SavePath
    
        wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=wbDest.Sheets(1).Range("A1")
            AccountFilename = Account.Value & "_Review 1.xlsx"
            On Error Resume Next
                wbDest.SaveAs SavePath & AccountFilename, FileFormat:=51
                
        SavePath = "C:\Users\JBH\Documents\Loan Data\Review 2\" & Account.Value & "\"
        If Dir(SavePath, vbDirectory) = vbNullString Then MkDir SavePath
        
        wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=wbDest.Sheets(1).Range("A1")
            AccountFilename = Account.Value & "_Review 2.xlsx"
            On Error Resume Next
                wbDest.SaveAs SavePath & AccountFilename, FileFormat:=51
                    
            On Error GoTo 0
            If wbDest.Name = AccountFilename Then counter = counter + 1
            wbDest.Sheets(1).UsedRange.ClearContents
    Next Account
    
    wbDest.Close SaveChanges:=False
    wsSource.AutoFilterMode = False
    Application.ScreenUpdating = True
    
    MsgBox counter & " files saved to " & SavePath, vbInformation, "Save Account Data"
    
End Sub

I still can't figure out how to get my data posted in the proper format, and how to copy the table from Sheet2.

I will give two gold stars to whomever may be able to offer insight! (Yes, I am reduced to bribery.)