split data to multiple sheets based on cell value

M

MKLAQ

Active Member
Joined
Jan 30, 2021
Messages
397
Office Version
  1. 2016
Platform
  1. Windows
hello
I have list customer of names in COL A and COL B are the date . each customer name contains group of customers . so what I want arranging the data by spliting each customer number should show in each sheet indivdaully and the group of customer should split to multiple columns based on number in cell F3 with the same borders and formatting . in this case should split each 5 cutomer in three columns ITEM, CUSTOMER ,DATE to reach the end of customers numbers
orginal data in sheet1
orginal.xlsm
ABCDEF
1
2LIST OF CUSTOMERDATECUSTOMR
35
4CUSTOMER1DATE
5
6AA-13-Feb-21 9:42 AM
7AA-23-Feb-21 9:45 AM
8AA-33-Feb-21 9:47 AM
9AA-43-Feb-21 9:42 AM
10AA-53-Feb-21 9:42 AM
11AA-63-Feb-21 9:42 AM
12AA-73-Feb-21 9:42 AM
13AA-83-Feb-21 9:42 AM
14AA-93-Feb-21 9:42 AM
15AA-103-Feb-21 9:42 AM
16AA-113-Feb-21 9:42 AM
17AA-123-Feb-21 9:42 AM
18AA-133-Feb-21 9:42 AM
19
20CUSTOMER2
21
22BB-13-Feb-21 9:42 AM
23BB-23-Feb-21 9:45 AM
24BB-33-Feb-21 9:48 AM
25BB-43-Feb-21 9:50 AM
26BB-53-Feb-21 9:53 AM
27BB-63-Feb-21 9:56 AM
28BB-73-Feb-21 9:58 AM
29BB-83-Feb-21 10:01 AM
30BB-93-Feb-21 10:04 AM
31BB-103-Feb-21 10:06 AM
32BB-113-Feb-21 10:09 AM
33BB-123-Feb-21 10:12 AM
34BB-133-Feb-21 10:14 AM
35BB-143-Feb-21 10:17 AM
ORGINAL


result in sheet customer1 when split based on F3
CUSTOMER1.xlsm
ABCDEFGHI
1LIST OF CUSTOMERdate
2
3ITEMCUSTOMER1DATEITEMCUSTOMER1DATEITEMCUSTOMER1DATE
41AA-13-Feb-21 9:42 AM1AA-63-Feb-21 9:42 AM1AA-113-Feb-21 9:42 AM
52AA-23-Feb-21 9:45 AM2AA-73-Feb-21 9:42 AM2AA-123-Feb-21 9:42 AM
63AA-33-Feb-21 9:47 AM3AA-83-Feb-21 9:42 AM3AA-133-Feb-21 9:42 AM
74AA-43-Feb-21 9:42 AM4AA-93-Feb-21 9:42 AM
85AA-53-Feb-21 9:42 AM5AA-103-Feb-21 9:42 AM
9
10
CUSTOMER1


SHEET CUSTOMER2
CUSTOMER2.xlsm
ABCDEFGHI
1LIST OF CUSTOMERdate
2
3ITEMCUSTOMER2DATEITEMCUSTOMER2DATEITEMCUSTOMER2DATE
41BB-13-Feb-21 9:42 AM1BB-63-Feb-21 9:56 AM1BB-113-Feb-21 10:09 AM
52BB-23-Feb-21 9:45 AM2BB-73-Feb-21 9:58 AM2BB-123-Feb-21 10:12 AM
63BB-33-Feb-21 9:48 AM3BB-83-Feb-21 10:01 AM3BB-133-Feb-21 10:14 AM
74BB-43-Feb-21 9:50 AM4BB-93-Feb-21 10:04 AM4BB-143-Feb-21 10:17 AM
85BB-53-Feb-21 9:53 AM5BB-103-Feb-21 10:06 AM
RESULT2
 
Last edited:

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Sort by date Sort by votes
This macro should work if you delete the blank rows below each customer name so the sheet looks like this:

MKLAQ.xlsm
ABCDEF
1
2LIST OF CUSTOMERDATECUSTOMR
35
4CUSTOMER1DATE
5AA-13-Feb-21 9:42 AM
6AA-23-Feb-21 9:45 AM
7AA-33-Feb-21 9:47 AM
8AA-43-Feb-21 9:42 AM
9AA-53-Feb-21 9:42 AM
10AA-63-Feb-21 9:42 AM
11AA-73-Feb-21 9:42 AM
12AA-83-Feb-21 9:42 AM
13AA-93-Feb-21 9:42 AM
14AA-103-Feb-21 9:42 AM
15AA-113-Feb-21 9:42 AM
16AA-123-Feb-21 9:42 AM
17AA-133-Feb-21 9:42 AM
18
19CUSTOMER2
20BB-13-Feb-21 9:42 AM
21BB-23-Feb-21 9:45 AM
22BB-33-Feb-21 9:48 AM
23BB-43-Feb-21 9:50 AM
24BB-53-Feb-21 9:53 AM
25BB-63-Feb-21 9:56 AM
26BB-73-Feb-21 9:58 AM
27BB-83-Feb-21 10:01 AM
28BB-93-Feb-21 10:04 AM
29BB-103-Feb-21 10:06 AM
30BB-113-Feb-21 10:09 AM
31BB-123-Feb-21 10:12 AM
32BB-133-Feb-21 10:14 AM
33BB-143-Feb-21 10:17 AM
ORIGINAL


VBA Code: 
Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim rng As Range, LastRow As Long, i As Long, fRow As Long, lRow As Long, lCol As Long, x As Long, cnt As Long, srcWS As Worksheet, y As Long: y = 2
    Set srcWS = Sheets("ORIGINAL")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With srcWS.Range("A4:A" & LastRow).SpecialCells(xlCellTypeConstants)
        For i = 1 To .Areas.Count
            fRow = .Areas(i).Cells(1).Row
            lRow = .Areas(i).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            x = .Areas(i).Cells.Count - 1
            cnt = WorksheetFunction.RoundUp(x / srcWS.Range("F3").Value, 0)
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = .Areas(i).Cells(1)
            Range("B1:C1").Value = Array("LIST OF CUSTOMER", "Date")
            For x = 1 To cnt
                Cells(3, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 3).Value = Array("ITEM", .Areas(i).Cells(1), "DATE")
                srcWS.Range("A" & fRow + 1).Resize(srcWS.Range("F3").Value, 2).Copy Cells(4, y)
                fRow = fRow + srcWS.Range("F3").Value
                y = y + 3
            Next x
            Range("A3").Delete
            lCol = Cells(3, Columns.Count).End(xlToLeft).Column - 1
            For Each rng In Range(Cells(4, lCol).Address).Resize(srcWS.Range("F3").Value)
                If rng = "" Then
                    rng.Resize(srcWS.Range("F3").Value + 4 - rng.Row, 2).ClearContents
                End If
            Next rng
            For x = 1 To lCol Step 3
                LastRow = Columns(x + 1).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                With Cells(4, x)
                    .Value = "1"
                    If LastRow - 3 > 1 Then
                        .AutoFill Destination:=Range(Cells(4, x).Address).Resize(LastRow - 3), Type:=xlFillSeries
                    End If
                End With
            Next x
            Columns.AutoFit
            y = 2
        Next i
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
thanks
but it gives application defined or object defined error in this line
VBA Code: 
For Each rng In Range(Cells(4, lCol).Address).Resize(srcWS.Range("F3").Value)
 
Upvote 0
great! but I have some things need fixing

1 - I increase data in column A ,B i try adding CUSTOMER3 and some data under it the code doesn't create it . every time increase data in COL A, B .

2- it should create with borders and formatting

3- finally when I run the macro repeatedly it shows error beacause has already create the sheet . what I want when run repeatedly should update in sheets are created if I change in sheet orginal and if i add a new customer also create it
 
Upvote 0
Try:
VBA Code: 
Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim rng As Range, LastRow As Long, i As Long, fRow As Long, lRow As Long, lCol As Long, x As Long, cnt As Long, srcWS As Worksheet, y As Long: y = 2
    Set srcWS = Sheets("ORIGINAL")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With srcWS.Range("A4:A" & LastRow).SpecialCells(xlCellTypeConstants)
        For i = 1 To .Areas.Count
            fRow = .Areas(i).Cells(1).Row
            lRow = .Areas(i).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            x = .Areas(i).Cells.Count - 1
            cnt = WorksheetFunction.RoundUp(x / srcWS.Range("F3").Value, 0)
            If Not Evaluate("isref('" & .Areas(i).Cells(1) & "'!A1)") Then
                Worksheets.Add(After:=Sheets(Sheets.Count)).Name = .Areas(i).Cells(1)
                Range("B1:C1").Value = Array("LIST OF CUSTOMER", "Date")
                For x = 1 To cnt
                    Cells(3, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 3).Value = Array("ITEM", .Areas(i).Cells(1), "DATE")
                    srcWS.Range("A" & fRow + 1).Resize(srcWS.Range("F3").Value, 2).Copy Cells(4, y)
                    fRow = fRow + srcWS.Range("F3").Value
                    y = y + 3
                Next x
                Range("A3").Delete
                lCol = Cells(3, Columns.Count).End(xlToLeft).Column - 1
                Range("A3").Resize(, lCol + 1).Interior.ColorIndex = 15
                For Each rng In Range(Cells(4, lCol).Address).Resize(srcWS.Range("F3").Value)
                    If rng = "" Then
                        rng.Resize(srcWS.Range("F3").Value + 4 - rng.Row, 2).ClearContents
                    End If
                Next rng
                For x = 1 To lCol Step 3
                    LastRow = Columns(x + 1).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    With Cells(4, x)
                        .Value = "1"
                        If LastRow - 3 > 1 Then
                            .AutoFill Destination:=Range(Cells(4, x).Address).Resize(LastRow - 3), Type:=xlFillSeries
                        End If
                    End With
                Next x
                Columns.AutoFit
                Range("A3").CurrentRegion.Borders.LineStyle = xlContinuous
            Else
                Application.DisplayAlerts = False
                Sheets(CStr(.Areas(i).Cells(1))).Delete
                Application.DisplayAlerts = True
                Worksheets.Add(After:=Sheets(Sheets.Count)).Name = .Areas(i).Cells(1)
                Range("B1:C1").Value = Array("LIST OF CUSTOMER", "Date")
                For x = 1 To cnt
                    Cells(3, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 3).Value = Array("ITEM", .Areas(i).Cells(1), "DATE")
                    srcWS.Range("A" & fRow + 1).Resize(srcWS.Range("F3").Value, 2).Copy Cells(4, y)
                    fRow = fRow + srcWS.Range("F3").Value
                    y = y + 3
                Next x
                Range("A3").Delete
                lCol = Cells(3, Columns.Count).End(xlToLeft).Column - 1
                Range("A3").Resize(, lCol + 1).Interior.ColorIndex = 15
                For Each rng In Range(Cells(4, lCol).Address).Resize(srcWS.Range("F3").Value)
                    If rng = "" Then
                        rng.Resize(srcWS.Range("F3").Value + 4 - rng.Row, 2).ClearContents
                    End If
                Next rng
                For x = 1 To lCol Step 3
                    LastRow = Columns(x + 1).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    With Cells(4, x)
                        .Value = "1"
                        If LastRow - 3 > 1 Then
                            .AutoFill Destination:=Range(Cells(4, x).Address).Resize(LastRow - 3), Type:=xlFillSeries
                        End If
                    End With
                Next x
                Columns.AutoFit
                Range("A3").CurrentRegion.Borders.LineStyle = xlContinuous
            End If
            y = 2
        Next i
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
about your file works perfectly but if I apply anotrher file it gives error in sheet name
VBA Code: 
 Worksheets.Add(After:=Sheets(Sheets.Count)).Name = .Areas(i).Cells(1)
why doesn't work . may attch my file to see where is the problem ,please?
 
Upvote 0
A macro that works on a sample file very often does not work on the actual file. I would have to see your actual file (de-sensitized if necessary). Please use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your actual sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.
 
Upvote 0
Hi MKLAQ,

In your original example in your data you had a blank row dividing the data. But you don't have it in your file.
In the name of the "customer" you have a colon, it is an invalid character to name a sheet.
1626473384146.png


Then it is necessary to identify a pattern to know when a new group of data begins.
In this example from your file, the group elements have "." for the file extension. But the name of the "group" does not have a dot, so I will consider the absence of a dot as the name of the "group".

For the following macro it is necessary that you create a sheet called "Template", in this sheet you apply the format that you want for the new sheets, for example:
1626473634244.png

Formatting is only required in cells A1 to C4

Try this code.
The macro removes invalid characters and also does not need a blank line between each group.

VBA Code: 
Sub split_data()
  Dim shO As Worksheet, shT As Worksheet, shD As Worksheet
  Dim c As Range, sName As String
  Dim i As Long, j As Long, k As Long, m As Long, n As Long
  
  Application.ScreenUpdating = False
  Set shO = Sheets("Original")
  Set shT = Sheets("Template")
  n = shO.Range("F3").Value
  
  For Each c In shO.Range("A4", shO.Range("A" & Rows.Count).End(3))
    If c.Value <> "" Then
      If InStr(1, Right(c.Value, 5), ".") = 0 Then
        If Not shD Is Nothing Then shD.Cells.Columns.AutoFit
        shT.Copy , Sheets(Sheets.Count)
        Set shD = ActiveSheet
        sName = Replace(Replace(Replace(Replace(c.Value, ":", " "), "\", " "), "/", " "), "?", " ")
        sName = Left(Replace(Replace(Replace(sName, "*", " "), "[", " "), "]", " "), 30)
        shD.Name = sName
        i = 4
        j = 1
        k = 1
        m = 0
      Else
        If m = n Then
          i = 4
          j = j + 3
          m = 0
          shT.Range("A3:C3").Copy shD.Cells(3, j)
        End If
        shT.Range("A4:C4").Copy shD.Cells(i, j)
        shD.Cells(i, j).Resize(1, 3).Value = Array(k, c.Value, c.Offset(, 1).Value)
        i = i + 1
        k = k + 1
        m = m + 1
      End If
    End If
  Next
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
VBA Copy & Paste Values onto itself based on Criteria
Replies
4
Views
242
mst3kr
M
J
  • Question
adding cells based on criteria across several columns
Replies
5
Views
97
Cubist
Cubist
J
  • Solved
removing 0s from output and cell staying in date format
Replies
5
Views
162
Joe4
Joe4
K
  • Question
conditional formatting question
Replies
2
Views
173
kerm007
K
J
  • Solved
iferror function conditional formatting
Replies
1
Views
122
Joe4
Joe4

Forum statistics

Threads
1,215,284
Messages
6,124,064
Members
449,139
Latest member
sramesh1024

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