VBA help - to split data copy existing sheets to new workbook

[Mallesh23]

Hi Team,

I have one input file, which contain list of city,every city has Data in it.

Task is split the data, Copy each sheet Data to a new workbook and

save new workbook with first two letters of Citi name.

if citi names of first two letter has come multiple times add all those sheets to single workbook.


Below is attempted code which works, but is there any alternate way to speed up the macro.


I have total 60 sheets in input file have to seperate it,

Output Generated 30 new workbook will generated, 30 sheets clubbed in same workbook where sheetnames matches with first two letter.

Time takes around 40 mins, Can we speed up the macro.

Option Explicit

Sub Seperate_Data_asperCiti()
    
    Dim wbk_s As Workbook
    Dim dest_wbk As Workbook
    Dim sht As Worksheet
    Dim i As Long
    Dim arr_citi As Variant

Application.DisplayAlerts = False
Application.ScreenUpdating = False

arr_citi = Array("IN", "MU", "PU", "BA", "HD", "GO", "HM", "AD", "TA", "SO", "KO", "Lo")  List is lenghty

For i = LBound(arr_citi) To UBound(arr_citi) ' Find sheetName as per city

    Set wbk_s = Workbooks.Open("D:\Input_File\Look_up.xlsx")

    For Each sht In wbk_s.Sheets
        If Left(sht.Name, 2) = arr_citi(i) Then
            If Dir(Path & "\" & arr_citi(i) & ".xlsx") = "" Then
                sht.Copy
                Application.ActiveWorkbook.SaveAs Filename = Path & "\" & arr_citi(i) & ".xlsx"
                Application.ActiveWorkbook.Close False
            Else
                Set dest_wbk = Workbooks.Open(Path & "\" & arr_citi(i) & ".xlsx", False, False)
                sht.Copy after:=dest_wbk.Sheets(dest_wbk.Worksheets.Count)
                dest_wbk.Save
                dest_wbk.Close True
            End If
        End If
    Next
Next i


wbk_s.Close True
MsgBox "Data seperated as per Citi"

Application.DisplayAlerts = true
Application.ScreenUpdating = true


End Sub

Thanks
mg

 

[Alex Blakenburg]

I have to run but in case it keeps you going.
1) Aren't you opening the same workbook each time inside the loop.
Wouldn't you do it once before starting the loop
This line: Set wbk_s = Workbooks.Open("D:\Input_File\Look_up.xlsx")
ie put it before
For i = LBound(arr_citi) To UBound(arr_citi) ' Find sheetName as per city

2) I haven't looked closely at this but is your "If statement" opening & closing the current workbook for arr_citi(i) more than once ?

 

[Mallesh23]

Hi Alex,

you are right we can put it before start of loop,

This macro what it does in short, it club\Copy all sheet names into new workbook if starting two letter are same.

for examle, if workbook contain sheet name like -{ Shiva, Shankar, Shivaji, ****al} So these sheet name should be clubbed into new workbook and saved as sh. if sheet name is Dhoni , then dhoni sheet name needs to copy to new workbook should be saved as DH and so on.




Thanks
mg

 

[Mallesh23]

Hi Team,

to simplify further , I am adding one more explaination.

How to copy multiple sheet name which has same First two letter and Needs to be added and saved to new workbook.

Arr = Array ("SA","DH","VI","AJ","MA")

Copy all sheet Name with SA** to new workbook, saveas SA.
Copy all Sheet Name with DH** save to new workbook as DH
Copy all sheet Name with VI** Save to new workbook with VI
Copy all Sheet Name with AJ** save to new workook as AJ
Copy all sheet Name with MA*** and save to new new workbook as MA***

Below is sample sheets

Thanks
mg

 

[Alex Blakenburg]

See if this works for you.
It only opens Look_Up once.
And only writes out each output workbook once.
I am not testing to see if the output workbook already exists, if you need to cater for that then you will need to modify the code.

Sub Separate_Data_asperCiti()
   
    Dim wbk_s As Workbook
    Dim dest_wbk As Workbook
    Dim sht As Worksheet
    Dim i As Long
    Dim arr_citi As Variant
    Dim Path As String
    Dim citiFound As String

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   
    arr_citi = Array("IN", "MU", "PU", "BA", "HD", "GO", "HM", "AD", "TA", "SO", "KO", "Lo")  'List is lenghty
      
    Set wbk_s = Workbooks.Open("D:\Input_File\Look_up.xlsx")
    Path = wbk_s.Path
   
    For i = LBound(arr_citi) To UBound(arr_citi) ' Find sheetName as per city
        citiFound = "N"
        For Each sht In wbk_s.Sheets
            If UCase(Left(sht.Name, 2)) = arr_citi(i) Then
                If citiFound = "N" Then
                    sht.Copy
                    Set dest_wbk = ActiveWorkbook
                    citiFound = "Y"
                Else
                    sht.Copy after:=dest_wbk.Sheets(dest_wbk.Worksheets.Count)
                End If
            End If
        Next sht
       
        If citiFound = "Y" Then
            Application.ActiveWorkbook.SaveAs Filename:=Path & "\" & arr_citi(i) & ".xlsx"
            Application.ActiveWorkbook.Close False
        End If
    Next i
    
    wbk_s.Close True
    MsgBox "Data seperated as per Citi"
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

 

[Alex Blakenburg]

Most of the gains will be in the minimizing the number of times the files are opened and saved.

If you want to make it a little faster:-
1) Change both of the sht.copy to sht.move
This means your loop of 60 will get smaller and smaller each time, as the number of worksheets in the Look_up reduces

2) Make sure you do not save the Lookup_Up since you have now stripped most of the sheets out of it.
Change the Close line to this

    wbk_s.Close SaveChanges:=False
    MsgBox "Data separated as per Citi"  ' fixes spelling of separated

If the code crashes for any reason make sure you don't save Look_up.
Perhaps in the code or manually make a backup of the workbook first.

 

[Mallesh23]

Hi alex,

Thanks for your help it worked ! ?


Thanks
mg

 

[Alex Blakenburg]

Hi alex,

Thanks for your help it worked ! ?


Thanks
mg

Thanks for letting me know. Glad I could help.
Would you mind clicking on the Mark as Solution checkmark to the right of the most useful post.
It lets other volunteers know that this query has been resolved so they can focus on the unresolved ones and also helps me with my stats.