Need help with macro to save multiple workbooks, based on groups of multiple values

[racebannon]

Hi:

I have the following spreadsheet that I need help creating a macro for:

CostCode SpentHours BillableAmount Project Code
010-0040 20 400.00 05424A
040-4104 5 110.00 05424A
101-0150 1 14.00 05424A
010-0040 2 20.00 05426B
030-0670 9 87.00 05426B
400-2470 3 43.00 05426B
200-0060 2 37.00 05426B

I need to have a macro that will copy rows based on groups of CostCodes, for a particular project to new Workbooks.

The grouping of costcodes will vary by project, but generally they follow the below pattern:

010,020,030,040,050,060,070,080,090,950 (using the first three digits of the CostCode)
100,200,300,350,400,450,500,550,600,650
101,201,301,351,401,451,501,551,601,650
102,202,302,352,402,452,502,552,602,652
103,203,303,353,403,453,503,553,603,653

So in the above example I would like the macro to generate the following new workbooks (saved to Sheet1):

FILE: 05424A_1.xls

CostCode SpentHours BillableAmount Project Code
010-0040 20 400.00 05424A
040-4104 5 110.00 05424A

FILE: 05424A_2.xls

CostCode SpentHours BillableAmount Project Code
101-0150 1 14.00 05424A

FILE: 05424B_1.xls

CostCode SpentHours BillableAmount Project Code
010-0040 2 20.00 05426B
030-0670 9 87.00 05426B

FILE: 05424B_2.xls

CostCode SpentHours BillableAmount Project Code
400-2470 3 43.00 05426B
200-0060 2 37.00 05426B

I've taken a look at a lot of macros on the internet, but haven't found one that's close to what I need.
I don't need the macro to ask the user for the groupings of cost codes, I can just change the VB code at the start of a project.

Any help is greatly appreciated, as I'm not good with VB!

 

[racebannon]

Got a solution working ...

Sub Search_SelectAndCopy()

Dim SheetData As String
Dim DataRowNum As Integer, SheetRowNum As Integer

'
Cells.Replace What:="CAD$", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'

SheetData = "Detailed" '// Source sheet
DataRowNum = 2 '//' Begin search at row 2
SheetRowNum = 2 '//' Begin saving data to row 2 in "sheetname"

'//' Select sheetname, as its apparently required before copying is allowed !
Worksheets(SheetData).Select

'//' Search and copy the data
While Not IsEmpty(Cells(DataRowNum, 2)) '//' Loop until column B gets blank


If (Range("E" & CStr(DataRowNum)).Value = "05424A") And (((Left(Range("A" & CStr(DataRowNum)).Value, 3) = "010") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "020")) Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "030") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "040") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "050") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "060") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "070") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "080") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "090")) Then

'//' Select entire row
Rows(CStr(DataRowNum) & ":" & CStr(DataRowNum)).Select
Selection.Copy

'//' Select target sheet to store the data "sheetname" and paste to next row
Sheets("Sheet1").Select
Rows(CStr(SheetRowNum) & ":" & CStr(SheetRowNum)).Select
Sheets("Sheet1").Paste
'ActiveSheet.Paste

SheetRowNum = SheetRowNum + 1 '//' Move to next row

'//' Select source sheet "SheetData" so searching can continue
Sheets("Detailed").Select
End If

DataRowNum = DataRowNum + 1 '//' Search next row
Wend

'//' Search and copying complete.
Sheets("Sheet1").Select
Range("A1").Select
ActiveCell.FormulaR1C1 = "CostCode"
Range("B1").Select
ActiveCell.FormulaR1C1 = "SpentHours"
Range("C1").Select
ActiveCell.FormulaR1C1 = "BillableAmount"
Range("C2").Select
Sheets("Sheet1").Columns.AutoFit
ThisFile = Range("E2").Value
ActiveWorkbook.SaveAs Filename:=ThisFile & "- Home Office Management & Support Services"

Exit Sub

Err_Execute:
MsgBox "An error occurred "

End Sub

 

[racebannon]

For some reason the macro is copying and saving data that doesn't meet the IF THEN condition. I want the macro to only copy the row IF Column E's value is 05424A AND Column A's value starts with 010,020,030,040,050,060,070,080, or 090.

Any suggestions for where I'm going wrong?

I found extra brackets, but it is still returning the wrong data with the revised statement:

If (Range("E" & CStr(DataRowNum)).Value = "05424A") And ((Left(Range("A" & CStr(DataRowNum)).Value, 3) = "010") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "020") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "030") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "040") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "050") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "060") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "070") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "080") Or (Left(Range("A" & CStr(DataRowNum)).Value, 3) = "090")) Then

 

[racebannon]

Solved the problem. There were too many instructions in the Macro to save multiple workbooks. I parsed the different saves across more then one module, and it works correctly.

Also modified the save instructions:


ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ThisFile & " - Pad X"

Now saves to the same directory where the source file is.