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

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
874
Office Version
  1. 2010
Platform
  1. Windows
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
VBA Code:
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
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

Alex Blakenburg

Well-known Member
Joined
Feb 23, 2021
Messages
607
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Feb 4, 2009
Messages
874
Office Version
  1. 2010
Platform
  1. Windows
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

Well-known Member
Joined
Feb 4, 2009
Messages
874
Office Version
  1. 2010
Platform
  1. Windows
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
1615970821352.png



Thanks
mg
 

Alex Blakenburg

Well-known Member
Joined
Feb 23, 2021
Messages
607
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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.

VBA 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

Well-known Member
Joined
Feb 23, 2021
Messages
607
Office Version
  1. 365
Platform
  1. Windows
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
VBA Code:
    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

Well-known Member
Joined
Feb 4, 2009
Messages
874
Office Version
  1. 2010
Platform
  1. Windows
Hi alex,

Thanks for your help it worked ! 🕺 (y)


Thanks
mg
 

Alex Blakenburg

Well-known Member
Joined
Feb 23, 2021
Messages
607
Office Version
  1. 365
Platform
  1. Windows
Hi alex,

Thanks for your help it worked ! 🕺 (y)


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.
 
Solution

Watch MrExcel Video

Forum statistics

Threads
1,130,083
Messages
5,639,980
Members
417,121
Latest member
DallyDally

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
Top