split data to multiple sheets based on cell value

M

MKLAQ

Active Member
Joined
Jan 30, 2021
Messages
387
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:
Sort by date Sort by votes
@DanteAmor thanks for correcting my mistake , I fixed it and runs very will

about your code doesn't work as what I want also not like mumps' code

so if you still interest when I apply your code as in post # 9 when create the header in a new sheet it should be the same sheet name

so the header is different from sheet to another not always CUSTOMER1 there is also CUSTOMER 2 , 3.... it 's based what I write every time increasing data

also when split data it should do with hyperlink .each header in first sheet link with hyperlink , then when I press the cell should open actually this point works , but not correctly it should apply in column CUSTOMER1 and should show the hyperlink all files under this header to open but show in column ITEM .this is not right also sometimes I change the data in first sheet then should update to all sheets created but when run repeatedly it gives error .
 
Upvote 0

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
@mumps after @DanteAmor provided me assistance about my mistake your code works but i need fix this problem when split data I can press the file for any a new sheet is created
because it split with hyperlink but the header it doesn't link hyperlink I m talking about post #9 it should also when split data doesn't hyperlink in the header after column ITEM
 
Upvote 0
You must have a blank row between each FOLDER NAME group. In your sample file, row 18 must be blank. Try:
VBA Code: 
Sub CreateSheets1()
    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('" & Replace(.Areas(i).Cells(1), ":", "-") & "'!A1)") Then
                Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Replace(.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(Replace(.Areas(i).Cells(1), ":", "-"))).Delete
                Application.DisplayAlerts = True
                Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Replace(.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
see my post#12 if this is not clear please tell me
 
Upvote 0
MKLAQ said:
if this is not clear please tell me
Click to expand...
Please explain in detail referring to specific cells, rows, columns and sheets based on the last file you posted.
 
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")
                    .Areas(i).Cells(1).Copy
                    Cells(3, Columns.Count).End(xlToLeft).Offset(, -1).PasteSpecial xlPasteAll
                    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")
                    .Areas(i).Cells(1).Copy
                    Cells(3, Columns.Count).End(xlToLeft).Offset(, -1).PasteSpecial xlPasteAll
                    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
Solution
@mumps exactly this is what I'm looking for. well done !
thanks so much for your assistance ;)
 
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
224
mst3kr
M
J
  • Solved
removing 0s from output and cell staying in date format
Replies
5
Views
142
Joe4
Joe4
K
  • Question
conditional formatting question
Replies
2
Views
149
kerm007
K
J
  • Solved
iferror function conditional formatting
Replies
1
Views
110
Joe4
Joe4
J
  • Question
using sumifs function across multiple sheets
Replies
4
Views
249
KRice
K

Forum statistics

Threads
1,214,524
Messages
6,120,049
Members
448,940
Latest member
mdusw

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