VBA to save each row in new workbook with header using name column as filename

[fiercemelon]

I've been asked to help a co-worker with her extremely repetitive task of saving each associates (about 200) billable time report in their own file with their name.

The header is in rows 1-7

Rows 8-end need to each be saved in their own workbook. The data is in columns A-Z.

The associates name is in column "A". Is it possible to reference this cell in creating a file name like... "AssociateName_BillableTimeReport".

Any help would be greatly appreciated

 

[JLGWhiz]

This is one way to do it.

Dim rng As Range, c As Range
fPath = ThisWorkbook.Path
Set rng = Sheets(1).Range("A8", sheets(1).Cells(Rwos.Count).End(xlUp))
 For Each c In rng
  fName = c.Value & "_BillableTimeReport"
  ActiveWorkbook.SaveAs fPath & "\" & fName 
 Next

 

[fiercemelon]

I'm getting an error message that reads

Compile error:
Invalid outside procedure

The text "thisworkbook" is highlighted, I am not sure how to fix this excatly, I've been tinkering with it throughout the day.

Dim rng As Range, c As Range
fPath = [I][B][FONT=arial black]ThisWorkbook[/FONT][/B][/I].Path
Set rng = Sheets(1).Range("A8", sheets(1).Cells(Rwos.Count).End(xlUp))
 For Each c In rng
  fName = c.Value & "_BillableTimeReport"
  ActiveWorkbook.SaveAs fPath & "\" & fName 
 Next

 

[JLGWhiz]

Maybe correcting my spelling errors and typos will help. Try it now.

Dim rng As Range, c As Range
fPath = ThisWorkbook.Path
Set rng = Sheets(1).Range("A8", sheets(1).Cells(Rows.Count, 1).End(xlUp))
 For Each c In rng
  fName = c.Value & "_BillableTimeReport"
  ActiveWorkbook.SaveAs fPath & "\" & fName 
 Next

 

[fiercemelon]

Hmmm...

I'm still having that exact same error.

The workbook is currently saved on my desktop. I saw something online that said perhaps opening the file through excel rather than the windows explorer would help. (It didn't)

Who knows, I will let you know if I figure out why I am getting this error.

 

[JLGWhiz]

Hmmm...

I'm still having that exact same error.

The workbook is currently saved on my desktop. I saw something online that said perhaps opening the file through excel rather than the windows explorer would help. (It didn't)

Who knows, I will let you know if I figure out why I am getting this error.

You don't have to use 'ThisWorkbook.Path'. You can put the actual path there, exmpl: "C:\Documents and Settings\"

 

[fiercemelon]

I got the code to execute, it is saving each file with the appropriate name. However, each file contains all rows still.

 

[JLGWhiz]

I thought you had the part for separating the data by name, I only addressed the saveas issue. I'ss see if I can work something up that will do it all.

 

[JLGWhiz]

This tested OK. Give it a try on a copy of the real thing. It filters the names in column A to get a list of Unique names, then uses that list to create individual workbooks, autofilter the source file and copy individual data to the new workbook, name the workbook with a saveas function and close the new workbook.

Sub time()
Dim sh As Worksheet, lr As Long, rng As Range, eRng As Range, c As Range, wb As Workbook
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("A7:A" & lr)
sh.Columns("AA").Insert
rng.AdvancedFilter xlFilterCopy, , sh.Range("AA1"), Unique:=True
Set eRng = sh.Range("AA2", sh.Cells(Rows.Count, 27).End(xlUp))
    For Each c In eRng
        Set wb = Workbooks.Add
        sh.Range("A1:Z7").Copy wb.Sheets(1).Range("A1")
        sh.Range("A7: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("AA").Delete
End Sub

 

[fiercemelon]

Any way to keep row/column heights as well as hidden row in header (row 1).