VBA to separate data to different workbooks

benishiryo

benishiryo

Board Regular
Joined
Feb 13, 2011
Messages
116
Hi guys. Tryin to do up a macro that separates different Account Codes in an original source to different workbooks. The ideal scenario wld be to transfer "AAA.01.0", "BBB.01.0" & "AAA.02.0" into different workbooks & save it in their respective Account Code names in a specific directory. So an end result for this case wld be 3 files in:

C:\AAA.01.0.xls
C:\BBB.01.0.xls
C:\AAA.02.0.xls

*Do note that the data may have a "CCC.01.0" or any other extra Account Code, so I do not know what might appear.
Alternatives if the above are nt possible can be to:
- Specify the Account Codes I know will appear (the 3 mentioned above) to extract to another workbook if unable to pick out new codes to extract (CCC.01.0 as stated above).
- Leave the workbooks open after the separation of data to save manually if unable to save into specific names & folders
- Separate them into worksheets instead of workbooks if unable to extract to another workbook.

<TABLE style="WIDTH: 157pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=209><COLGROUP><COL style="WIDTH: 37pt; mso-width-source: userset; mso-width-alt: 1792" width=49><COL style="WIDTH: 72pt; mso-width-source: userset; mso-width-alt: 3510" width=96><COL style="WIDTH: 48pt" width=64><TBODY><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: silver; WIDTH: 37pt; HEIGHT: 12.75pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl71 height=17 width=49>A</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: silver; WIDTH: 72pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl71 width=96>B</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: silver; WIDTH: 48pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl71 width=64>C</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: silver; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl71 height=17>1</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; BORDER-TOP: #f0f0f0; BORDER-RIGHT: windowtext 0.5pt solid" class=xl69>Account Code</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; BORDER-TOP: #f0f0f0; BORDER-RIGHT: windowtext 0.5pt solid" class=xl70>Amt</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: silver; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl71 height=17>2</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: #99ccff; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl66>AAA.01.0</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: #99ccff; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 align=right>35,406.00</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: silver; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl71 height=17>3</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: #99ccff; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl66>AAA.01.0</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: #99ccff; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 align=right>2,321.00</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: silver; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl71 height=17>4</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: #ccffcc; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl67>BBB.01.0</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: #ccffcc; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl64 align=right>4,541.00</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: silver; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl71 height=17>5</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: #99ccff; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl66>AAA.01.0</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: #99ccff; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 align=right>9,814.00</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: silver; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl71 height=17>6</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: #ffff99; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl68>AAA.02.0</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: #ffff99; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 align=right>1,229.00</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: silver; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl71 height=17>7</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: #ccffcc; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl67>BBB.01.0</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: #ccffcc; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl64 align=right>87,464.00</TD></TR></TBODY></TABLE>
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Sort by date Sort by votes
Assuming that Row 1 contains the column headers, and Column A contains the account code, make sure that the sheet containing the data is the active sheet and try...

Code: 
[font=Courier New][color=darkblue]Option[/color] [color=darkblue]Explicit[/color]

[color=darkblue]Sub[/color] CreateWorkbooks()

    [color=darkblue]Dim[/color] strDestPath [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] wkbDest [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] wksDest [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] rngUniqueVals [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] rngCell [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] CalcMode [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] LastRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=darkblue]With[/color] Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = [color=darkblue]False[/color]
        .ScreenUpdating = [color=darkblue]False[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    [color=darkblue]If[/color] LastRow > 1 [color=darkblue]Then[/color]

        strDestPath = "C:\Users\Domenic\Desktop\"   [color=green]'change the path accordingly[/color]
        
        [color=darkblue]If[/color] Right(strDestPath, 1) <> "\" [color=darkblue]Then[/color] strDestPath = strDestPath & "\"
    
        Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterInPlace, unique:=[color=darkblue]True[/color]
        
        [color=darkblue]Set[/color] rngUniqueVals = Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
        
        [color=darkblue]For[/color] [color=darkblue]Each[/color] rngCell [color=darkblue]In[/color] rngUniqueVals
            [color=darkblue]With[/color] ActiveSheet.UsedRange
                .AutoFilter field:=1, Criteria1:=rngCell.Value
                .Copy
                [color=darkblue]Set[/color] wkbDest = Workbooks.Add(xlWBATWorksheet)
                [color=darkblue]Set[/color] wksDest = wkbDest.Worksheets(1)
                wksDest.Range("A1").PasteSpecial
                wkbDest.SaveAs strDestPath & rngCell.Value & ".xls"
                wkbDest.Close savechanges:=[color=darkblue]False[/color]
            [color=darkblue]End[/color] [color=darkblue]With[/color]
        [color=darkblue]Next[/color] rngCell
        
        ActiveSheet.AutoFilterMode = [color=darkblue]False[/color]
        
        [color=darkblue]With[/color] Application
            .Calculation = CalcMode
            .EnableEvents = [color=darkblue]True[/color]
            .ScreenUpdating = [color=darkblue]True[/color]
        [color=darkblue]End[/color] [color=darkblue]With[/color]
        
        MsgBox "Completed...", vbInformation
    
    [color=darkblue]Else[/color]
    
        MsgBox "No data is available...", vbExclamation
        
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
[/font]
 
Upvote 0
Thanks Domenic, it works!! I know I sound exaggerated, but this is really AWESOME! Saves me lots of time. I'm always amazed by how much VBA can do. I even thought that there might be some stuff I requested that may not be possible, but wowww.

2 more qns:
1. Is it possible for the VBA to name the worksheet too? (Getting a little greedy~) By the account code too
2. I want to use this for another worksheet of mine. This time the Account code is at Column F & the Account code is longer. It is still to be divided into different workbooks according to the last 3 segments like the above.

<TABLE style="WIDTH: 144pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=192><COLGROUP><COL style="WIDTH: 144pt; mso-width-source: userset; mso-width-alt: 7021" width=192><TBODY><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; WIDTH: 144pt; HEIGHT: 12.75pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=17 width=192>Account Code</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: #99ccff; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl66 height=17>1.41103.56.564.0000.AAA.01.0</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: #99ccff; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl66 height=17>1.41103.56.564.0000.AAA.01.0</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: #ccffcc; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl67 height=17>1.41202.56.564.0000.BBB.01.0</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: #99ccff; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl66 height=17>1.41103.56.564.0000.AAA.01.0</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: #ffff99; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl68 height=17>1.41103.56.564.0000.AAA.02.0</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: #ccffcc; HEIGHT: 12.75pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl67 height=17>1.41202.56.564.0000.BBB.01.0</TD></TR></TBODY></TABLE>
 
Upvote 0
benishiryo said:
Thanks Domenic, it works!!
Click to expand...

You're welcome!

1. Is it possible for the VBA to name the worksheet too?
Click to expand...

Add the following line of code in red...

Code: 
[font=Courier New][color=darkblue]For[/color] [color=darkblue]Each[/color] rngCell [color=darkblue]In[/color] rngUniqueVals
    [color=darkblue]With[/color] ActiveSheet.UsedRange
        .AutoFilter field:=1, Criteria1:=rngCell.Value
        .Copy
        [color=darkblue]Set[/color] wkbDest = Workbooks.Add(xlWBATWorksheet)
        [color=darkblue]Set[/color] wksDest = wkbDest.Worksheets(1)
        [COLOR="Red"]wksDest.Name = rngCell.Value[/COLOR]
        wksDest.Range("A1").PasteSpecial
        wkbDest.SaveAs strDestPath & rngCell.Value & ".xls"
        wkbDest.Close savechanges:=[color=darkblue]False[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
[color=darkblue]Next[/color] rngCell[/font]

2. I want to use this for another worksheet of mine. This time the Account code is at Column F & the Account code is longer. It is still to be divided into different workbooks according to the last 3 segments like the above.
Click to expand...

Assuming that the last 3 segments are always 8 digits in length, try...

Code: 
[font=Courier New][color=darkblue]Option[/color] [color=darkblue]Explicit[/color]

[color=darkblue]Sub[/color] CreateWorkbooks()

    [color=darkblue]Dim[/color] strDestPath [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] wkbDest [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] wksDest [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] rngUniqueVals [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] rngCell [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] CalcMode [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] LastRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=darkblue]With[/color] Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = [color=darkblue]False[/color]
        .ScreenUpdating = [color=darkblue]False[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    LastRow = Cells(Rows.Count, "F").End(xlUp).Row
    
    [color=darkblue]If[/color] LastRow > 1 [color=darkblue]Then[/color]

        strDestPath = "C:\Users\Domenic\Desktop\"
        
        [color=darkblue]If[/color] Right(strDestPath, 1) <> "\" [color=darkblue]Then[/color] strDestPath = strDestPath & "\"
    
        Range("F1:F" & LastRow).AdvancedFilter Action:=xlFilterInPlace, unique:=[color=darkblue]True[/color]
        
        [color=darkblue]Set[/color] rngUniqueVals = Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible)
        
        [color=darkblue]For[/color] [color=darkblue]Each[/color] rngCell [color=darkblue]In[/color] rngUniqueVals
            [color=darkblue]With[/color] ActiveSheet.UsedRange
                .AutoFilter field:=6, Criteria1:=rngCell.Value
                .Copy
                [color=darkblue]Set[/color] wkbDest = Workbooks.Add(xlWBATWorksheet)
                [color=darkblue]Set[/color] wksDest = wkbDest.Worksheets(1)
                wksDest.Name = Right(rngCell.Value, 8)
                wksDest.Range("A1").PasteSpecial
                wkbDest.SaveAs strDestPath & Right(rngCell.Value, 8) & ".xls"
                wkbDest.Close savechanges:=[color=darkblue]False[/color]
            [color=darkblue]End[/color] [color=darkblue]With[/color]
        [color=darkblue]Next[/color] rngCell
        
        ActiveSheet.AutoFilterMode = [color=darkblue]False[/color]
        
        [color=darkblue]With[/color] Application
            .Calculation = CalcMode
            .EnableEvents = [color=darkblue]True[/color]
            .ScreenUpdating = [color=darkblue]True[/color]
        [color=darkblue]End[/color] [color=darkblue]With[/color]
        
        MsgBox "Completed...", vbInformation
    
    [color=darkblue]Else[/color]
    
        MsgBox "No data is available...", vbExclamation
        
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
[/font]
 
Upvote 0
Hi Donomic, thks again but there are 2 problems I faced:

1. The data I showed previously would not have a problem but if I changed the 2nd segment of the Account Code, it wld not work.
The VBA seem to be separating the Account Code by looking at the whole text (ie 1.41103.56.564.0000.AAA.01.0) instead of just the last 8 characters. Hence, when VBA was running for the 2nd account code there was a prompt that asked if I wanted to overwrite 000.02.0
This 2 shld actually be in a same file because the last 8 characters are the same.

2. When I am opening the file in the specified directory, there was a prompt saying “The file you are trying to open, ‘000.02.0.xls’ is in a different format than specified by the file extension. Verify that the file is not corrupted and is from a trusted source before opening the file. Do you want to open the file now?”
This only happens in XL2007, but works fine in XL2003
<TABLE style="WIDTH: 146pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=194><COLGROUP><COL style="WIDTH: 146pt; mso-width-source: userset; mso-width-alt: 7094" width=194><TBODY><TR style="HEIGHT: 13.5pt" height=18><TD style="BORDER-BOTTOM: #3867a6 1pt solid; BORDER-LEFT: #3867a6 1pt solid; BACKGROUND-COLOR: #efefef; WIDTH: 146pt; HEIGHT: 13.5pt; BORDER-TOP: #3867a6 1pt solid; BORDER-RIGHT: #3867a6 1pt solid" class=xl65 height=18 width=194>Account Code

</TD></TR><TR style="HEIGHT: 13.5pt" title="Post 2743185" height=18><TD style="BORDER-BOTTOM: #3867a6 1pt solid; BORDER-LEFT: #3867a6 1pt solid; BACKGROUND-COLOR: #99ccff; WIDTH: 146pt; HEIGHT: 13.5pt; BORDER-TOP: #3867a6; BORDER-RIGHT: #3867a6 1pt solid" class=xl66 height=18 width=194>1.41103.56.564.0000.AAA.01.0</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="BORDER-BOTTOM: #3867a6 1pt solid; BORDER-LEFT: #3867a6 1pt solid; BACKGROUND-COLOR: #ccc0da; WIDTH: 146pt; HEIGHT: 13.5pt; BORDER-TOP: #3867a6; BORDER-RIGHT: #3867a6 1pt solid" class=xl67 height=18 width=194>1.31103.56.564.0000.AAA.01.0</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="BORDER-BOTTOM: #3867a6 1pt solid; BORDER-LEFT: #3867a6 1pt solid; BACKGROUND-COLOR: #ccffcc; WIDTH: 146pt; HEIGHT: 13.5pt; BORDER-TOP: #3867a6; BORDER-RIGHT: #3867a6 1pt solid" class=xl68 height=18 width=194>1.41202.56.564.0000.BBB.01.0</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="BORDER-BOTTOM: #3867a6 1pt solid; BORDER-LEFT: #3867a6 1pt solid; BACKGROUND-COLOR: #99ccff; WIDTH: 146pt; HEIGHT: 13.5pt; BORDER-TOP: #3867a6; BORDER-RIGHT: #3867a6 1pt solid" class=xl66 height=18 width=194>1.41103.56.564.0000.AAA.01.0</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="BORDER-BOTTOM: #3867a6 1pt solid; BORDER-LEFT: #3867a6 1pt solid; BACKGROUND-COLOR: #ffff99; WIDTH: 146pt; HEIGHT: 13.5pt; BORDER-TOP: #3867a6; BORDER-RIGHT: #3867a6 1pt solid" class=xl69 height=18 width=194>1.41103.56.564.0000.AAA.02.0</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="BORDER-BOTTOM: #3867a6 1pt solid; BORDER-LEFT: #3867a6 1pt solid; BACKGROUND-COLOR: #ccffcc; WIDTH: 146pt; HEIGHT: 13.5pt; BORDER-TOP: #3867a6; BORDER-RIGHT: #3867a6 1pt solid" class=xl68 height=18 width=194>1.41202.56.564.0000.BBB.01.0

</TD></TR></TBODY></TABLE>
 
Upvote 0
Try the following amended macros instead. For the original and subsequent macros, a section of the code that changes the application settings has been moved to the appropriate spot, and the file format has been specified. For the subsequent macro, the code has been changed so that only the last 8 characters are used in determining unique values. Also, have a look at http://www.rondebruin.nl/saveas.htm.

Original Macro:

Code: 
[font=Courier New][color=darkblue]Option[/color] [color=darkblue]Explicit[/color]

[color=darkblue]Sub[/color] CreateWorkbooks()

    [color=darkblue]Dim[/color] strDestPath [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] wkbDest [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] wksDest [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] rngUniqueVals [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] rngCell [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] CalcMode [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] LastRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    [color=darkblue]If[/color] LastRow > 1 [color=darkblue]Then[/color]

        [color=darkblue]With[/color] Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .EnableEvents = [color=darkblue]False[/color]
            .ScreenUpdating = [color=darkblue]False[/color]
        [color=darkblue]End[/color] [color=darkblue]With[/color]
        
        strDestPath = "C:\Users\Domenic\Desktop\"
        
        [color=darkblue]If[/color] Right(strDestPath, 1) <> "\" [color=darkblue]Then[/color] strDestPath = strDestPath & "\"
    
        Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterInPlace, unique:=[color=darkblue]True[/color]
        
        [color=darkblue]Set[/color] rngUniqueVals = Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
        
        [color=darkblue]For[/color] [color=darkblue]Each[/color] rngCell [color=darkblue]In[/color] rngUniqueVals
            [color=darkblue]With[/color] ActiveSheet.UsedRange
                .AutoFilter field:=1, Criteria1:=rngCell.Value
                .Copy
                [color=darkblue]Set[/color] wkbDest = Workbooks.Add(xlWBATWorksheet)
                [color=darkblue]Set[/color] wksDest = wkbDest.Worksheets(1)
                wksDest.Name = rngCell.Value
                wksDest.Range("A1").PasteSpecial
                wkbDest.SaveAs strDestPath & rngCell.Value & ".xls", 56
                wkbDest.Close savechanges:=[color=darkblue]False[/color]
            [color=darkblue]End[/color] [color=darkblue]With[/color]
        [color=darkblue]Next[/color] rngCell
        
        ActiveSheet.AutoFilterMode = [color=darkblue]False[/color]
        
        [color=darkblue]With[/color] Application
            .Calculation = CalcMode
            .EnableEvents = [color=darkblue]True[/color]
            .ScreenUpdating = [color=darkblue]True[/color]
        [color=darkblue]End[/color] [color=darkblue]With[/color]
        
        MsgBox "Completed...", vbInformation
    
    [color=darkblue]Else[/color]
    
        MsgBox "No data is available...", vbExclamation
        
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
[/font]

Subsequent Macro:

Code: 
[font=Courier New][color=darkblue]Option[/color] [color=darkblue]Explicit[/color]

[color=darkblue]Sub[/color] CreateWorkbooks()

    [color=darkblue]Dim[/color] strDestPath [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] wkbDest [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] wksDest [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] rngUniqueVals [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] rngCell [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] CalcMode [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] LastRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] LastColumn [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=darkblue]With[/color] ActiveSheet.UsedRange
        LastRow = .Rows.Count + .Rows(1).Row - 1
        LastColumn = .Columns.Count + .Columns(1).Column - 1
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=darkblue]If[/color] LastRow > 1 [color=darkblue]Then[/color]

        [color=darkblue]With[/color] Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .EnableEvents = [color=darkblue]False[/color]
            .ScreenUpdating = [color=darkblue]False[/color]
        [color=darkblue]End[/color] [color=darkblue]With[/color]
        
        strDestPath = "C:\Users\Domenic\Desktop\"
        
        [color=darkblue]If[/color] Right(strDestPath, 1) <> "\" [color=darkblue]Then[/color] strDestPath = strDestPath & "\"
        
        Cells(1, LastColumn + 1).Value = "Code"
        
        Range(Cells(2, LastColumn + 1), Cells(LastRow, LastColumn + 1)).FormulaR1C1 = "=RIGHT(RC6,8)"
        
        Range(Cells(1, LastColumn + 1), Cells(LastRow, LastColumn + 1)).AdvancedFilter Action:=xlFilterInPlace, unique:=[color=darkblue]True[/color]
        
        [color=darkblue]Set[/color] rngUniqueVals = Range(Cells(2, LastColumn + 1), Cells(LastRow, LastColumn + 1)).SpecialCells(xlCellTypeVisible)
        
        [color=darkblue]For[/color] [color=darkblue]Each[/color] rngCell [color=darkblue]In[/color] rngUniqueVals
            [color=darkblue]With[/color] ActiveSheet.UsedRange
                .AutoFilter field:=LastColumn + 1, Criteria1:=rngCell.Value
                .Resize(, LastColumn).Copy
                [color=darkblue]Set[/color] wkbDest = Workbooks.Add(xlWBATWorksheet)
                [color=darkblue]Set[/color] wksDest = wkbDest.Worksheets(1)
                wksDest.Name = Right(rngCell.Value, 8)
                wksDest.Range("A1").PasteSpecial
                wkbDest.SaveAs Filename:=strDestPath & Right(rngCell.Value, 8) & ".xls", FileFormat:=56
                wkbDest.Close savechanges:=[color=darkblue]False[/color]
            [color=darkblue]End[/color] [color=darkblue]With[/color]
        [color=darkblue]Next[/color] rngCell
        
        ActiveSheet.AutoFilterMode = [color=darkblue]False[/color]
        
        Columns(LastColumn + 1).ClearContents
        
        [color=darkblue]With[/color] Application
            .Calculation = CalcMode
            .EnableEvents = [color=darkblue]True[/color]
            .ScreenUpdating = [color=darkblue]True[/color]
        [color=darkblue]End[/color] [color=darkblue]With[/color]
        
        MsgBox "Completed...", vbInformation
    
    [color=darkblue]Else[/color]
    
        MsgBox "No data is available...", vbExclamation
        
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
[/font]
 
Last edited:
Upvote 0
Really appreciate yr help, Domenic! It works & u have really lightened my workload. The link is very informative too. I am trying to study line by line wat the VBA code means cause they look real complicated! Hope that u can help explain if I hav any queries. Thank U~
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
VBA Function to Paste Table into Outlook Email Resulting in HTML language in Email
Replies
8
Views
623
smozgur
smozgur
A
  • Question Question
VBA - Automatically Break the Line in HTML format.
Replies
7
Views
2K
Attrazion
A
G
  • Question Question
Using Excel formula to create HTML code text referencing specific cells
Replies
0
Views
1K
gvsumich
G
E
  • Question Question
VBA code clean up
Replies
9
Views
583
mumps
mumps
E
  • Question Question
VBA for Web Scraping help
Replies
0
Views
921
epactheactor
E

Forum statistics

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

Share this page

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