Split Data to Several Sheet from large sheet

ASK

New Member
Joined
Nov 10, 2021
Messages
2
Office Version
  1. 2016
Platform
  1. Windows
I am struggling to copy and paste data from large sheet and need help if anyone can help me to write VBA.

I want to split data from main sheet named “ALL DATA” to multiple sheets.

Headers are from A1 to M1 in Row A1

Name of sheets are entered in Column (“A2:A”)

I want to copy data from column (A2: D2) & rows can be many of “ALL DATA” sheet

I want to create sheets automatically by names given in Column (“A2:A”) if not already created and copy data in each sheet when I run Macro.
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,223
Office Version
  1. 365
Platform
  1. Windows
Hello Ask,

Here's one method that you could try:-

VBA Code:
Option Explicit

Sub Test()

              Dim i As Long, lr As Long
              Dim sh As Worksheet, wsD As Worksheet, ar As Variant
        
Application.ScreenUpdating = False
        
              Set sh = Sheets("ALL DATA")
              lr = sh.Range("A" & Rows.Count).End(xlUp).Row
              sh.Range("A1:A" & lr).AdvancedFilter 2, , sh.[Z1], 1  'Unique values moved temporarily to Column Z.
              sh.Range("Z2", sh.Range("Z" & sh.Rows.Count).End(xlUp)).Sort [Z2], 1 'Unique values sorted.
              ar = sh.Range("Z2", sh.Range("Z" & sh.Rows.Count).End(xlUp))
              
       For i = 1 To UBound(ar)
              If Not Evaluate("ISREF('" & CStr(ar(i, 1)) & "'!A1)") Then
                    Sheets.Add(After:=Sheets(Worksheets.Count)).Name = ar(i, 1)
              End If
                    
              Set wsD = Sheets(CStr(ar(i, 1)))
              wsD.UsedRange.Clear
                    
              With sh.[A1].CurrentRegion
                   .AutoFilter 1, ar(i, 1)
                   .Resize(, 4).Copy wsD.[A1]
                   .AutoFilter
             End With
                   wsD.Columns.AutoFit
                   sh.Columns("Z").Clear
       Next i

Application.Goto sh.[A1]
Application.ScreenUpdating = True

End Sub

I'm assuming that you only have the "ALL DATA" sheet in your workbook currently.
The above code will create new worksheets for each unique name in Column A and then transfer the relevant rows of data (from Columns A:D only) to their respective sheets.
Please test the code in a copy of your actual workbook first.

I hope that this helps.
Cheerio,
vcoolio.
 
Solution

ASK

New Member
Joined
Nov 10, 2021
Messages
2
Office Version
  1. 2016
Platform
  1. Windows
Hello Ask,

Here's one method that you could try:-

VBA Code:
Option Explicit

Sub Test()

              Dim i As Long, lr As Long
              Dim sh As Worksheet, wsD As Worksheet, ar As Variant
       
Application.ScreenUpdating = False
       
              Set sh = Sheets("ALL DATA")
              lr = sh.Range("A" & Rows.Count).End(xlUp).Row
              sh.Range("A1:A" & lr).AdvancedFilter 2, , sh.[Z1], 1  'Unique values moved temporarily to Column Z.
              sh.Range("Z2", sh.Range("Z" & sh.Rows.Count).End(xlUp)).Sort [Z2], 1 'Unique values sorted.
              ar = sh.Range("Z2", sh.Range("Z" & sh.Rows.Count).End(xlUp))
             
       For i = 1 To UBound(ar)
              If Not Evaluate("ISREF('" & CStr(ar(i, 1)) & "'!A1)") Then
                    Sheets.Add(After:=Sheets(Worksheets.Count)).Name = ar(i, 1)
              End If
                   
              Set wsD = Sheets(CStr(ar(i, 1)))
              wsD.UsedRange.Clear
                   
              With sh.[A1].CurrentRegion
                   .AutoFilter 1, ar(i, 1)
                   .Resize(, 4).Copy wsD.[A1]
                   .AutoFilter
             End With
                   wsD.Columns.AutoFit
                   sh.Columns("Z").Clear
       Next i

Application.Goto sh.[A1]
Application.ScreenUpdating = True

End Sub

I'm assuming that you only have the "ALL DATA" sheet in your workbook currently.
The above code will create new worksheets for each unique name in Column A and then transfer the relevant rows of data (from Columns A:D only) to their respective sheets.
Please test the code in a copy of your actual workbook first.

I hope that this helps.
Cheerio,
vcoolio.
Thank you dear. It works perfectly. I really appreciate you.
 

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,223
Office Version
  1. 365
Platform
  1. Windows
You're welcome Ask. I'm glad to have been able to assist and thanks for the feed back.

Cheerio,
vcoolio.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,116
Messages
5,768,211
Members
425,459
Latest member
Danniey

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