Saving to separate workbooks depending on cell contents?

chuckles1066

Banned
Joined
Dec 20, 2004
Messages
372
Hi,

Hope someone can help, you guys haven't failed me yet :-)

I have inherited a task at work which is currently being done manually and takes about 3 hours :-(

I have a spreadsheet. In column A there is text stating "jobs allocated to" followed by a workman's name (e.g "jobs allocated to chuckles1066").

There then follows a list of jobs and then a row of "*" which terminates his list of jobs.

Then the sequence repeats, "jobs allocated to", a list of jobs and then a row of "*".

I have to CTRL-F, find the next instance of "jobs allocated to", highlight everything above that, cut and paste it into a new workbook and save it as the name of the workman.

Can I automate it?

TIA.
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
This should work:

Code:
Sub chuckles1066()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    For myrowcounter = 1 To Range("A" & Rows.Count).End(xlUp).Row
        If Left(Cells(myrowcounter, 1).Value, 17) = "jobs allocated to" Then
            workmanname = Right(Cells(myrowcounter, 1).Value, Len(Cells(myrowcounter, 1).Value) - 18)
            Do Until Cells(myrowcounter + myjobscounter, 1).Value = "*"
                myjobscounter = myjobscounter + 1
            Loop
            Range(myrowcounter & ":" & (myjobscounter + myrowcounter)).Copy
            With Workbooks.Add
                .ActiveSheet.Paste
                .ActiveSheet.Cells(1, 1).Select
                .SaveAs (workmanname)
                .Close
            End With
            myrowcounter = myrowcounter + myjobscounter
            myjobscounter = 0
        End If
    Next
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

If you want to watch the progress, you can comment out
Code:
Application.ScreenUpdating = False
Also if you don't want the "jobs allocated to...." and "*" rows to be copied, you can change:
Code:
Range(myrowcounter & ":" & (myjobscounter + myrowcounter)).Copy

to:

Code:
Range(myrowcounter+1 & ":" & (myjobscounter + myrowcounter-1)).Copy

Workman files will be saved to the same folder as the source file. If the workman file already exists, it will be overwritten. However the macro will fail if a filename of the same name as the workman is already open, so best to keep such files closed.
 
Upvote 0
Very impressive, it works a treat, thank you very much!

Is there a way to have the macro save the resultant files as tab-text delimited?
 
Upvote 0
Great, glad it works. Yeah sure that can be done. Use the following:

Code:
Sub chuckles1066()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    myPath = ActiveWorkbook.Path
    For myrowcounter = 1 To Range("A" & Rows.Count).End(xlUp).Row
        If Left(Cells(myrowcounter, 1).Value, 17) = "jobs allocated to" Then
            workmanname = Right(Cells(myrowcounter, 1).Value, Len(Cells(myrowcounter, 1).Value) - 18)
            Do Until Cells(myrowcounter + myjobscounter, 1).Value = "*"
                myjobscounter = myjobscounter + 1
            Loop
            Range(myrowcounter & ":" & (myjobscounter + myrowcounter)).Copy
            With Workbooks.Add
                .ActiveSheet.Paste
                .ActiveSheet.Cells(1, 1).Select
                .SaveAs (myPath & "\" & workmanname)
                .SaveAs (myPath & "\" & workmanname), xlCurrentPlatformText
                .Close
            End With
            myrowcounter = myrowcounter + myjobscounter
            myjobscounter = 0
        End If
    Next
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

It'll save in both your default Excel format as well as tab-separated text.
 
Upvote 0
Thanks again, I take my hat off to you Excel geniuses (or is that genii?) :-)

I have no idea how you manage to come up with this stuff, truly amazing!
 
Upvote 0

Forum statistics

Threads
1,224,599
Messages
6,179,827
Members
452,946
Latest member
JoseDavid

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
Back
Top