Split Data into separate worksheet based on Cell values

earthworm

Well-known Member
Joined
May 19, 2009
Messages
773
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
I have a below sample data set

Testing.xlsb
ABCDE
1S.noABCD
2A1783873724745
3A1867796903796
4A1993780713737
5A1701859909850
6A1829918745750
7A1812850874906
8A1880783769919
9A1734837876944
10A1888732864749
11A1942773711864
12A1920758771825
13A2964754912964
14A2839727872895
15A2926834730811
16A2792793767938
17A2892857950902
18A2982979866973
19A3765880789777
20A3918883789956
21A3795739735747
22A3724807747718
23A3976943864752
24A3983769848992
25A3855717954890
26A3989917873849
27A3862792956954
28A4908865848780
29A4911740952701
30A4851999786736
31A4868987794857
32A4805888725835
33A4788763951798
34A4901912855932
35A4757736761937
36A4708989965903
37A4782769802877
38A4864990829721
39A4790918971843
40A4866892817711
41A4790786718818
42A4928978798786
43A5980746751832
44A5962928847982
45A5890838704825
46A5821924792877
47A5989730798956
48A5913957991777
49A5899880812901
50A5988999863881
51A5842765767799
52A5908747999933
53A5914967897781
54A5733726918771
55A5969870929943
56A5853831905987
57A5895794707715
58A5975803935790
59A5813836764708
60A5847946788990
61A5990823723753
62A5711874708960
63A5755747905830
64A5878831849832
65A5733957994704
66A5869894966804
67A5989853951848
68A5982839973750
69A5714763968868
70A5967823834860
Sheet1


I need to split data based on below table in seperate worksheet and save on PC Desktop

Testing.xlsb
GHIJ
1Total CountData CountSplitSizeNumber of Files
2A11153
3A2652
4A3952
5A41553
6A52856
Sheet1
Cell Formulas
RangeFormula
H2:H6H2=COUNTIF(A:A,G2)
J2:J6J2=CEILING(H2/I2,1)
Named Ranges
NameRefers ToCells
_FilterDatabase=Sheet1!$A$1:$E$70H2:H6


Example Apply Filter on Column A1 and select value based on Range G1 and then select the first 5 rows of the filtered data , copy and paste the data in new worksheet along with header and save it on desktop. then again select data of filtered data in Column A1 and select the from 6th rosw of remaining data till 5 data and save second sheet and lastly select last value of A1 and save it in seperate worksheet . There will be 3 files containing all A1 data. and move to next value I.E A2 and so on.
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
I have a below sample data set

Testing.xlsb
ABCDE
1S.noABCD
2A1783873724745
3A1867796903796
4A1993780713737
5A1701859909850
6A1829918745750
7A1812850874906
8A1880783769919
9A1734837876944
10A1888732864749
11A1942773711864
12A1920758771825
13A2964754912964
14A2839727872895
15A2926834730811
16A2792793767938
17A2892857950902
18A2982979866973
19A3765880789777
20A3918883789956
21A3795739735747
22A3724807747718
23A3976943864752
24A3983769848992
25A3855717954890
26A3989917873849
27A3862792956954
28A4908865848780
29A4911740952701
30A4851999786736
31A4868987794857
32A4805888725835
33A4788763951798
34A4901912855932
35A4757736761937
36A4708989965903
37A4782769802877
38A4864990829721
39A4790918971843
40A4866892817711
41A4790786718818
42A4928978798786
43A5980746751832
44A5962928847982
45A5890838704825
46A5821924792877
47A5989730798956
48A5913957991777
49A5899880812901
50A5988999863881
51A5842765767799
52A5908747999933
53A5914967897781
54A5733726918771
55A5969870929943
56A5853831905987
57A5895794707715
58A5975803935790
59A5813836764708
60A5847946788990
61A5990823723753
62A5711874708960
63A5755747905830
64A5878831849832
65A5733957994704
66A5869894966804
67A5989853951848
68A5982839973750
69A5714763968868
70A5967823834860
Sheet1


I need to split data based on below table in seperate worksheet and save on PC Desktop

Testing.xlsb
GHIJ
1Total CountData CountSplitSizeNumber of Files
2A11153
3A2652
4A3952
5A41553
6A52856
Sheet1
Cell Formulas
RangeFormula
H2:H6H2=COUNTIF(A:A,G2)
J2:J6J2=CEILING(H2/I2,1)
Named Ranges
NameRefers ToCells
_FilterDatabase=Sheet1!$A$1:$E$70H2:H6


Example Apply Filter on Column A1 and select value based on Range G1 and then select the first 5 rows of the filtered data , copy and paste the data in new worksheet along with header and save it on desktop. then again select data of filtered data in Column A1 and select the from 6th rosw of remaining data till 5 data and save second sheet and lastly select last value of A1 and save it in seperate worksheet . There will be 3 files containing all A1 data. and move to next value I.E A2 and so on.
What do you want these new workbooks to be called and what do you want the sheet to be called?
 
Upvote 0
What do you want these new workbooks to be called and what do you want the sheet to be called?
Workbook to be name as A1 part 1 A1 Part 2 and so on depending on data sheet count. However if there is a data for one workbook only it should be name as A1. And when A2 starts it should name as A2

Sheet name default is not an issue

Please note that data should be save as separate workbook
 
Upvote 0
Give this a go on a copy of your data.

I have assumed that the sheet containing your data is called 'Data' and that the other sheet is called 'Spec' but you can change those names in the code where indicated.

It saves the files in the same folder but that can be changed. The path is stored on the strPath variable.

VBA Code:
Public Sub subSplitData()
Dim arrSpec() As Variant
Dim arrData() As Variant
Dim WsSpec As Worksheet
Dim WsData As Worksheet
Dim i As Integer
Dim ii As Integer
Dim rngFound As Range
Dim intOffset As Integer
Dim lngSize As Long
Dim strPath As String
Dim intCount As Integer

    ActiveWorkbook.Save
    
    Application.ScreenUpdating = False
    
    strPath = ActiveWorkbook.Path & "\"  ' CHANGE THE PATH AS APPROPRIATE.

    Set WsData = Worksheets("Data") ' CHANGE THIS WORKSHEET NAME AS APPROPRIATE.
        
    Set WsSpec = Worksheets("Spec") ' CHANGE THIS WORKSHEET NAME AS APPROPRIATE.
        
    With WsSpec
        arrSpec = .Range("G2:J" & .Range("G2").CurrentRegion.Rows.Count).Value
    End With
        
    For i = LBound(arrSpec) To UBound(arrSpec)
    
        Set rngFound = WsData.Range("A1").CurrentRegion.Columns(1).Find(arrSpec(i, 1), LookIn:=xlValues).Resize(arrSpec(i, 3), 4)
        
        intOffset = arrSpec(i, 3)
        
        lngSize = arrSpec(i, 3)
        
        For ii = 1 To arrSpec(i, 4)
            
            If ii = arrSpec(i, 4) And ((arrSpec(i, 2) Mod arrSpec(i, 3)) <> 0) Then
                lngSize = (arrSpec(i, 2) Mod arrSpec(i, 3))
            End If
         
            Application.DisplayAlerts = False
            On Error Resume Next
            Kill strPath & arrSpec(i, 1) & " part " & ii & ".xlsx"
            On Error GoTo 0
            Application.DisplayAlerts = True
            
            Workbooks.Add
            With ActiveWorkbook
                .SaveAs strPath & arrSpec(i, 1) & " part " & ii
                rngFound.Resize(lngSize, 4).Copy .Sheets(1).Range("A2")
                .Sheets(1).Range("A1:D1").Value = WsData.Range("A1:D1").Value
                .Sheets(1).name = arrSpec(i, 1)
                .Close True
            End With
            
            Set rngFound = rngFound.Offset(intOffset, 0).Resize(lngSize, 4)
          
            intCount = intCount + 1
            
        Next ii
    
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox intCount & " files created.", vbOKOnly, "Confirmation."

End Sub
 
Upvote 0
The code is working perfectly fine . However I need to make some changes as per my requirement . But I am lost . Can you please make the changes in code as per below data set


RDA Working for Other Bank Auto File.xlsb
ABCDEFGHIJ
1Transaction Reference NumberAcccount NoBeneficiary Name Amount BankTotal CountData CountSplitSizeNumber of Files
2ABLABL30178150003
3ABLBAF10402150001
4ABLBAHL29523150002
5ABLFAY6610150001
6ABLHBL74470150005
7ABLMEEZAN62254150005
8ABLMCB18528150002
9ABLBOP12101150001
10ABLSCB3845150001
11ABLJS3028150001
12ABLDIB2358150001
13ABLHMB5222150001
14ABLSAMBA238150001
For RDA Bank
Cell Formulas
RangeFormula
G2:G15G2=UNIQUE(E2:E1048575)
H2:H14H2=COUNTIF($E$2:$E$1048575,G2)
J2:J14J2=CEILING(H2/I2,1)
Dynamic array formulas.
 
Upvote 0
Give this a go on a copy of your data.

I have assumed that the sheet containing your data is called 'Data' and that the other sheet is called 'Spec' but you can change those names in the code where indicated.

It saves the files in the same folder but that can be changed. The path is stored on the strPath variable.

VBA Code:
Public Sub subSplitData()
Dim arrSpec() As Variant
Dim arrData() As Variant
Dim WsSpec As Worksheet
Dim WsData As Worksheet
Dim i As Integer
Dim ii As Integer
Dim rngFound As Range
Dim intOffset As Integer
Dim lngSize As Long
Dim strPath As String
Dim intCount As Integer

    ActiveWorkbook.Save
   
    Application.ScreenUpdating = False
   
    strPath = ActiveWorkbook.Path & "\"  ' CHANGE THE PATH AS APPROPRIATE.

    Set WsData = Worksheets("Data") ' CHANGE THIS WORKSHEET NAME AS APPROPRIATE.
       
    Set WsSpec = Worksheets("Spec") ' CHANGE THIS WORKSHEET NAME AS APPROPRIATE.
       
    With WsSpec
        arrSpec = .Range("G2:J" & .Range("G2").CurrentRegion.Rows.Count).Value
    End With
       
    For i = LBound(arrSpec) To UBound(arrSpec)
   
        Set rngFound = WsData.Range("A1").CurrentRegion.Columns(1).Find(arrSpec(i, 1), LookIn:=xlValues).Resize(arrSpec(i, 3), 4)
       
        intOffset = arrSpec(i, 3)
       
        lngSize = arrSpec(i, 3)
       
        For ii = 1 To arrSpec(i, 4)
           
            If ii = arrSpec(i, 4) And ((arrSpec(i, 2) Mod arrSpec(i, 3)) <> 0) Then
                lngSize = (arrSpec(i, 2) Mod arrSpec(i, 3))
            End If
        
            Application.DisplayAlerts = False
            On Error Resume Next
            Kill strPath & arrSpec(i, 1) & " part " & ii & ".xlsx"
            On Error GoTo 0
            Application.DisplayAlerts = True
           
            Workbooks.Add
            With ActiveWorkbook
                .SaveAs strPath & arrSpec(i, 1) & " part " & ii
                rngFound.Resize(lngSize, 4).Copy .Sheets(1).Range("A2")
                .Sheets(1).Range("A1:D1").Value = WsData.Range("A1:D1").Value
                .Sheets(1).name = arrSpec(i, 1)
                .Close True
            End With
           
            Set rngFound = rngFound.Offset(intOffset, 0).Resize(lngSize, 4)
         
            intCount = intCount + 1
           
        Next ii
   
    Next i
   
    Application.ScreenUpdating = True
   
    MsgBox intCount & " files created.", vbOKOnly, "Confirmation."

End Sub

Please help me make some minor tweaks in fitting as per my data shape
 
Upvote 0

Forum statistics

Threads
1,223,234
Messages
6,170,891
Members
452,366
Latest member
TePunaBloke

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