Split data are existed in two sheets to two sheets for each group

A

abdo meghari

Well-known Member
Joined
Aug 3, 2021
Messages
712
Office Version
  1. 2019
Hello,
I would macro to deal with about 10000 rows and contain about 100 groups for each sheet.
in SELLING,BUYING sheet should split data based on column B for each group ,as to column C should match with sheets names(SALES,COSTING) are already existed and show data for each sheet based on sheet name is existed in column C for SELLING,BUYING sheets.



ABDO (1).xls
ABCDEFGHI
1DATEGROUP/COMPANYTYPEBRAND NODESCRIBEUNITQTYSELLING PRICETOTAL
201/01/2025GOMMESTSALES1769 BLUE TR414 100 PCSPIECE250.45011.250
301/01/2025TIRESSALES1130GC 1200R20 QAZ183 CHIPIECE51,450.0007,250.000
401/01/2025BATTERYSALES1118XPRO 70A L KORPIECE1350.000350.000
501/01/2025BATTERYSALES1119XPRO 70A R KORPIECE2300.000600.000
602/01/2025GOMMESTSALES1774 BOAF0-50PIECE2100.900189.000
703/01/2025GOMMESTSALES1775 XIA TW-9250 250MLPIECE10.9500.950
804/01/2025TIRESSALES1123BS 750R16 R230 JAPPIECE10450.0004,500.000
905/01/2025TIRESSALES1124BS 750R16 VSJ JAPPIECE8750.0006,000.000
1006/01/2025GOMMESTSALES1752 EUS-65 ROUND PATCH 65X65 PIECE102.50025.000
1106/01/2025GOMMESTSALES1758 P1108 TAIWANPIECE115.50060.500
1206/01/2025GOMMESTSALES1773 PTO-2301-R 0.6X100MM.PIECE881.500132.000
1306/01/2025GOMMESTSALES1765 VMTC 7.50-16 V3-02-7PIECE160.00060.000
1406/01/2025TIRESSALES1125BS 1200R20 G580 JAPPIECE22,500.0005,000.000
1506/01/2025TIRESSALES1126BS 315/80R22.5 R184 JAPPIECE801,950.000156,000.000
1607/01/2025TIRESSALES1127BS 1400R20 VSJ JAPPIECE14,000.0004,000.000
1708/01/2025GOMMESTSALES1767HEADER OF PRESSUREPIECE14.0004.000
1809/01/2025GOMMESTSALES1768LEAD 10GM WIDEPIECE30.7502.250
1910/01/2025GOMMESTSALES1769LEAD 10GM TIDEPIECE70.8505.950
2011/01/2025GOMMESTSALES1770LEAD 15GM WIDEPIECE40.6502.600
2112/01/2025GOMMESTSALES1771LEAD 15GM TIDEPIECE60.9505.700
2213/01/2025GOMMESTSALES1772LEAD 20GM WIDEPIECE70.7004.900
2314/01/2025GOMMESTSALES1773LEAD 20GM TIDEPIECE160.80012.800
2415/01/2025TIRESSALES1128BS 1200R24 G580 JAPPIECE22,800.0005,600.000
2516/01/2025TIRESSALES1129GC 1200R20 AZ026 CHIPIECE21,350.0002,700.000
2617/01/2025BATTERYSALES1120XPRO 90A R KORPIECE2425.000850.000
2718/01/2025BATTERYSALES1121HANKOOK 150A L KORPIECE10850.0008,500.000
2819/01/2025BATTERYSALES1123ASIMCO 150A L KORPIECE1750.000750.000
SELLING
Cell Formulas
RangeFormula
I2:I28I2=H2*G2




ABDO (1).xls
ABCDEFGHI
1DATEGROUP/COMPANYTYPEBRAND NODESCRIBEUNITQTYCOSTING PRICETOTAL
201/01/2025GOMMESTCOSTING1765 VMTC 7.50-16 V3-02-7PIECE10045.0004,500.000
302/01/2025GOMMESTCOSTING1767HEADER OF PRESSUREPIECE1100.55060.500
403/01/2025TIRESCOSTING1126BS 315/80R22.5 R184 JAPPIECE1001,900.000190,000.000
504/01/2025TIRESCOSTING1127BS 1400R20 VSJ JAPPIECE203,900.00078,000.000
605/01/2025TIRESCOSTING1130GC 1200R20 QAZ183 CHIPIECE301,400.00042,000.000
705/01/2025TIRESCOSTING1133GC 1200R20 QAZ188 CHIPIECE201,500.00030,000.000
806/01/2025BATTERYCOSTING1118XPRO 70A L KORPIECE1300.000300.000
907/01/2025BATTERYCOSTING1119XPRO 70A R KORPIECE2250.000500.000
1008/01/2025GOMMESTCOSTING1768LEAD 10GM WIDEPIECE2000.25050.000
1109/01/2025GOMMESTCOSTING1769 BLUE TR414 100 PCSPIECE1250.33041.250
1210/01/2025GOMMESTCOSTING1752 EUS-65 ROUND PATCH 65X65 PIECE1001.500150.000
1311/01/2025GOMMESTCOSTING1758 P1108 TAIWANPIECE153.50052.500
1412/01/2025TIRESCOSTING1125BS 1200R20 G580 JAPPIECE102,400.00024,000.000
1513/01/2025TIRESCOSTING1128BS 1200R24 G580 JAPPIECE202,700.00054,000.000
1614/01/2025TIRESCOSTING1129GC 1200R20 AZ026 CHIPIECE301,300.00039,000.000
1715/01/2025GOMMESTCOSTING1773 PTO-2301-R 0.6X100MM.PIECE901.250112.500
1816/01/2025GOMMESTCOSTING1775 XIA TW-9250 250MLPIECE120.4905.880
1917/01/2025GOMMESTCOSTING1769LEAD 10GM TIDEPIECE170.3505.950
2018/01/2025GOMMESTCOSTING1770LEAD 15GM WIDEPIECE440.44019.360
2119/01/2025GOMMESTCOSTING1771LEAD 15GM TIDEPIECE660.45029.700
2220/01/2025GOMMESTCOSTING1772LEAD 20GM WIDEPIECE770.46035.420
2321/01/2025GOMMESTCOSTING1773LEAD 20GM TIDEPIECE1660.47078.020
2421/01/2025GOMMESTCOSTING1774 BOAF0-50PIECE2500.480120.000
2521/01/2025GOMMESTCOSTING1775 BOAF0-51PIECE1000.65065.000
2621/01/2025TIRESCOSTING1123BS 750R16 R230 JAPPIECE50400.00020,000.000
2721/01/2025TIRESCOSTING1124BS 750R16 VSJ JAPPIECE80700.00056,000.000
2822/01/2025BATTERYCOSTING1122NOVA 150A L KORPIECE1700.000700.000
2923/01/2025BATTERYCOSTING1123ASIMCO 150A L KORPIECE2700.0001,400.000
3024/01/2025BATTERYCOSTING1120XPRO 90A R KORPIECE2400.000800.000
3125/01/2025BATTERYCOSTING1121HANKOOK 150A L KORPIECE10800.0008,000.000
BUYING
Cell Formulas
RangeFormula
I2:I31I2=H2*G2




ABDO (1).xls
ABCDEFGH
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
SALES


ABDO (1).xls
ABCDEFG
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
COSTING


when split data if the C3,E3 are empty in SPLIT sheet
ABDO (1).xls
ABCDEF
1
2FROM DATETO DATE
3
4
5
6
7
8
split



then should split data like this
ABDO (1).xls
ABCDEFG
1GROUP/COMPANY: GOMMEST
2ITEMBRAND NODESCRIBEUNITQTYSELLING PRICETOTAL
311769 BLUE TR414 100 PCSPIECE250.45011.250
421752 EUS-65 ROUND PATCH 65X65 PIECE102.50025.000
531758 P1108 TAIWANPIECE115.50060.500
641773 PTO-2301-R 0.6X100MM.PIECE881.500132.000
751765 VMTC 7.50-16 V3-02-7PIECE160.00060.000
861767HEADER OF PRESSUREPIECE14.0004.000
971768LEAD 10GM WIDEPIECE30.7502.250
1081769LEAD 10GM TIDEPIECE70.8505.950
1191770LEAD 15GM WIDEPIECE40.6502.600
12101771LEAD 15GM TIDEPIECE60.9505.700
13111772LEAD 20GM WIDEPIECE70.7004.900
14121773LEAD 20GM TIDEPIECE160.80012.800
15131774 BOAF0-50PIECE2100.900189.000
16141775 XIA TW-9250 250MLPIECE10.9500.950
17SELLING TOTAL516.900
18
19
20
21GROUP/COMPANY: TIRES
22ITEMBRAND NODESCRIBEUNITQTYSELLING PRICETOTAL
2311123BS 750R16 R230 JAPPIECE10450.0004,500.000
2421124BS 750R16 VSJ JAPPIECE8750.0006,000.000
2531125BS 1200R20 G580 JAPPIECE22,500.0005,000.000
2641126BS 315/80R22.5 R184 JAPPIECE801,950.000156,000.000
2751127BS 1400R20 VSJ JAPPIECE14,000.0004,000.000
2861128BS 1200R24 G580 JAPPIECE22,800.0005,600.000
2971129GC 1200R20 AZ026 CHIPIECE21,350.0002,700.000
3081130GC 1200R20 QAZ183 CHIPIECE51,450.0007,250.000
31SELLING TOTAL191,050.000
32
33
34GROUP/COMPANY: BATTERY
35ITEMBRAND NODESCRIBEUNITQTYSELLING PRICETOTAL
3611118XPRO 70A L KORPIECE1350.000350.000
3721119XPRO 70A R KORPIECE2300.000600.000
3831120XPRO 90A R KORPIECE2425.000850.000
3941121HANKOOK 150A L KORPIECE10850.0008,500.000
4051123ASIMCO 150A L KORPIECE1750.000750.000
41SELLING TOTAL11,050.000
SALES
Cell Formulas
RangeFormula
G36:G40,G23:G30,G3:G16G3=F3*E3
G17G17=SUM(G3:G16)
G31G31=SUM(G23:G30)
G41G41=SUM(G36:G40)



ABDO (1).xls
ABCDEFG
1GROUP/COMPANY: GOMMEST
2ITEMBRAND NODESCRIBEUNITQTYCOSTING PRICETOTAL
351765 VMTC 7.50-16 V3-02-7PIECE10045.0004,500.000
461767HEADER OF PRESSUREPIECE1100.55060.500
571768LEAD 10GM WIDEPIECE2000.25050.000
611769 BLUE TR414 100 PCSPIECE1250.33041.250
721752 EUS-65 ROUND PATCH 65X65 PIECE1001.500150.000
831758 P1108 TAIWANPIECE153.50052.500
941773 PTO-2301-R 0.6X100MM.PIECE901.250112.500
10141775 XIA TW-9250 250MLPIECE120.4905.880
1181769LEAD 10GM TIDEPIECE170.3505.950
1291770LEAD 15GM WIDEPIECE440.44019.360
13101771LEAD 15GM TIDEPIECE660.45029.700
14111772LEAD 20GM WIDEPIECE770.46035.420
15121773LEAD 20GM TIDEPIECE1660.47078.020
16131774 BOAF0-50PIECE2500.480120.000
17141775 BOAF0-51PIECE1000.65065.000
18COSTING TOTAL715.580
19
20
21GROUP/COMPANY: TIRES
22ITEMBRAND NODESCRIBEUNITQTYCOSTING PRICETOTAL
2311125BS 1200R20 G580 JAPPIECE102,400.00024,000.000
2421128BS 1200R24 G580 JAPPIECE202,700.00054,000.000
2531129GC 1200R20 AZ026 CHIPIECE301,300.00039,000.000
2641123BS 750R16 R230 JAPPIECE50400.00020,000.000
2751124BS 750R16 VSJ JAPPIECE80700.00056,000.000
2861126BS 315/80R22.5 R184 JAPPIECE1001,900.000190,000.000
2971127BS 1400R20 VSJ JAPPIECE203,900.00078,000.000
3081130GC 1200R20 QAZ183 CHIPIECE301,400.00042,000.000
3191133GC 1200R20 QAZ188 CHIPIECE201,500.00030,000.000
32COSTING TOTAL455,000.000
33
34
35GROUP/COMPANY: BATTERY
36ITEMBRAND NODESCRIBEUNITQTYCOSTING PRICETOTAL
3711118XPRO 70A L KORPIECE1300.000300.000
3821119XPRO 70A R KORPIECE2250.000500.000
3931122NOVA 150A L KORPIECE1700.000700.000
4041123ASIMCO 150A L KORPIECE2700.0001,400.000
4151120XPRO 90A R KORPIECE2400.000800.000
4261121HANKOOK 150A L KORPIECE10800.0008,000.000
43COSTING TOTAL11,700.000
COSTING
Cell Formulas
RangeFormula
G37:G42,G23:G31,G3:G17G3=F3*E3
G18G18=SUM(G6:G17)
G32G32=SUM(G25:G31)
G43G43=SUM(G37:G42)




otherwise when there are dates then split within dates in C3,E3 in SPLIT sheet.
thanks.
 
Sort by date Sort by votes
Upvote 0
That may confuse issues
Click to expand...
sorry buddy !
I'll soon post you the next version that will hopefully run in 2010
Click to expand...
Ok , but I have question , does work for you with 2019 version?
Is there any chance that you and your employer can update to 365 as you will find it much easier to work with and there will be more people on forums that will be able to help you?
Click to expand...
it's hard to do that , sorry !
most of employees work with old versions , so hardly to convince to work with 365 version.
 
Upvote 0
abdo meghari said:
sorry buddy !

Ok , but I have question , does work for you with 2019 version?

it's hard to do that , sorry !
most of employees work with old versions , so hardly to convince to work with 365 version.
Click to expand...
Version 3.

Start and end dates default to 01/01/1900 and 01.01.2200 respectively.

VBA Code: 
Option Explicit

' *************************************************************************************
' VERSION 3
' *************************************************************************************
Public Sub subFilterSourceDataV3()
Dim WsSource As Worksheet
Dim WsTemp As Worksheet
Dim i As Integer
Dim arrFeed(1 To 2, 1 To 2) As Variant
Dim intLoop As Integer
Dim dteStart As Long
Dim dteEnd As Long
Dim strSheets As String

  ActiveWorkbook.Save
    
  dteStart = Worksheets("Split").Range("C3")
  
  If dteStart = 0 Then
    dteStart = DateSerial(1900, 1, 1)
  End If
  
  dteEnd = Worksheets("Split").Range("E3")
  
  If dteEnd = 0 Then
    dteEnd = DateSerial(2200, 1, 1)
  End If
   
  arrFeed(1, 1) = "SELLING"
  arrFeed(1, 2) = "SALES"
  arrFeed(2, 1) = "BUYING"
  arrFeed(2, 2) = "COSTING"
  
  Application.ScreenUpdating = True
  
  For intLoop = 1 To UBound(arrFeed)
  
    Set WsSource = Worksheets(arrFeed(intLoop, 1))
    
    WsSource.Columns(1).NumberFormat = "dd/mm/yyyy"
        
    Call subCreateSheet(arrFeed(intLoop, 2))
    
    Call subCreateSheet("Temp")
    
    Set WsTemp = Worksheets("Temp")
    
    strSheets = strSheets & vbCrLf & arrFeed(intLoop, 2)
    
    With WsSource.Range("A1").CurrentRegion
         
        .AutoFilter
               
        .AutoFilter Field:=1, _
          Criteria1:=">=" & dteStart, _
          Operator:=xlAnd, _
          Criteria2:="<=" & dteEnd
            
        .SpecialCells(xlCellTypeVisible).Copy
        
        With WsTemp
                
          .Activate
          
          .Range("A1").PasteSpecial xlPasteAll
          
          .Range("A1").Select
          
          .Range("A1").CurrentRegion.Sort Key1:=Range("B1"), Order1:=xlAscending, _
                           Key2:=Range("E1"), Order2:=xlAscending, Header:=xlYes
        
        End With
        
        .AutoFilter
      
    End With
    
    WsTemp.Rows(1).Font.Bold = True
        
    Call subScrollDown(Worksheets(arrFeed(intLoop, 2)))
    
  Next intLoop

  Application.ScreenUpdating = True
  
  Application.DisplayAlerts = False
  On Error Resume Next
  Worksheets("Temp").Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
  
  ActiveWorkbook.Save
  
  MsgBox "Report sheets created." & strSheets, vbOKOnly, "Confirmation."
  
End Sub

Private Sub subScrollDown(ByVal WsDestination As Worksheet)
Dim arrData() As Variant
Dim i As Integer
Dim intColumn As Integer
Dim s As String
Dim lngRow As Long
Dim rngCell As Range
Dim intItem As Integer
Dim dblValue As Double

  WsDestination.Activate

  Worksheets("Temp").Range("A1").Value = "ITEM"
    
  arrData = Worksheets("Temp").Range("A1").CurrentRegion.Value
  
  lngRow = 1
  
  For i = 1 To UBound(arrData)
  
    If i > 1 Then
    
      dblValue = dblValue + arrData(i, 9)
    
      If arrData(i, 2) <> arrData(i - 1, 2) Then
        
        ActiveWindow.ScrollRow = lngRow - 1
        intItem = 1
        arrData(i, 1) = intItem
        intItem = intItem + 1
        lngRow = lngRow + 4
        
        With WsDestination
                      
          .Cells(lngRow - 2, 5).Value = "GROUP/COMPANY : " & arrData(i, 2)
          Call subBorders(.Cells(lngRow - 2, 5))
          .Rows(lngRow - 2).Font.Bold = True
          .Rows(1).Copy
          .Rows(lngRow - 1).PasteSpecial xlPasteValues
          .Rows(lngRow - 1).Font.Bold = True
          Call subBorders(WsDestination.Range("A" & lngRow - 1, "I" & lngRow - 1))
        
        End With
        
      Else
        arrData(i, 1) = intItem
        intItem = intItem + 1
      End If
      
    End If
  
    For intColumn = 1 To UBound(arrData, 2)
      WsDestination.Cells(lngRow, intColumn).Value = arrData(i, intColumn)
      Call subBorders(WsDestination.Range("A" & lngRow, "I" & lngRow))
    Next intColumn
    
    If i <> UBound(arrData) Then
      If arrData(i, 2) <> arrData(i + 1, 2) Then
        Call subTotals(WsDestination.Cells(lngRow + 1, 9), dblValue, "Total")
        dblValue = 0
      End If
    End If
    
    With WsDestination.Cells(lngRow, 1)
     .NumberFormat = "0"
    End With
    
    lngRow = lngRow + 1
  
  Next i
  
  Call subTotals(WsDestination.Cells(lngRow, 9), dblValue, "Total")
    
  WsDestination.Activate
  
  Call subFormatWorksheet(WsDestination)

End Sub

Private Sub subTotals(rng As Range, dblTotal As Double, strLabel As String)

  rng.Value = dblTotal
  
  Call subBorders(rng)
  
  With fncOffset(rng, 0, -1)
    .Value = strLabel
    .Font.Bold = True
  End With
  
  Call subBorders(fncOffset(rng, 0, -1))
  
End Sub

Private Sub subBorders(rngBorders As Range)

  With rngBorders.Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = vbBlack
  End With

End Sub

Private Sub subFormatWorksheet(Ws As Worksheet)

  With Ws.Cells
      
    With .Font
      .Name = "Arial"
      .Size = 11
    End With
    
    .RowHeight = 20
    
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlCenter
    .IndentLevel = 1
      
    .Rows("1:2").EntireRow.Delete
    
    .Columns("B:C").Delete
        
    .EntireColumn.AutoFit
    
  End With

End Sub

Private Sub subCreateSheet(ByVal strSheet As String)
Dim WsActive As Worksheet

  Set WsActive = ActiveSheet

  If Evaluate("isref('" & strSheet & "'!A1)") Then
     Worksheets(strSheet).Cells.Clear
  Else
     Worksheets.Add after:=Sheets(Sheets.Count)
     ActiveSheet.Name = strSheet
  End If
  
  WsActive.Activate

End Sub

Public Function fncOffset(rng As Range, lngRows As Long, lngColumns As Long) As Range
Dim intRows As Integer
Dim intColumns As Integer
Dim rngFirst As Range
Dim Ws As Worksheet

  Set Ws = Worksheets(rng.Parent.Name)

  ' Reposition the top left cell in the range.
  Set rngFirst = Ws.Cells(rng.Row + lngRows, rng.Column + lngColumns)
    
  intRows = rng.Rows.Count
  
  intColumns = rng.Columns.Count

  ' Resize the range.
  Set fncOffset = rngFirst.Resize(intRows, intColumns)
    
End Function
 
Upvote 0
Solution
abdo meghari said:
Thanks again .:biggrin:
works for just COSTING sheet , no any data in SALES sheet!
Click to expand...
I'm using the data that you posted in your original post.

Does it work with that data?

Try copyimg the BUYING data into the SELLING sheet to see what happens.
 
Upvote 0
Does it work with that data?
Click to expand...
just with BUYING sheet works with version 2010.
with version 2019 works both sheets if C3,E3 are empty ,but if contain dates will not show any thing!
 
Upvote 0
abdo meghari said:
just with BUYING sheet works with version 2010.
with version 2019 works both sheets if C3,E3 are empty ,but if contain dates will not show any thing!
Click to expand...
Change the year on this line to 1950.

dteStart = DateSerial(1900, 1, 1)

What dates are you using?
 
Upvote 0
abdo meghari said:
just with BUYING sheet works with version 2010.
with version 2019 works both sheets if C3,E3 are empty ,but if contain dates will not show any thing!
Click to expand...
If you are using the test file that you posted in your cross post then your selling dates are all 2024 and your buying dates are all 2025,
You are unlikely to put date criteria in the Split sheet that will produce results for both Selling and Costing since you have no overlapping date range.
 
Upvote 0
Alex Blakenburg said:
If you are using the test file that you posted in your cross post then your selling dates are all 2024 and your buying dates are all 2025,
You are unlikely to put date criteria in the Split sheet that will produce results for both Selling and Costing since you have no overlapping date range.
Click to expand...
I didn't spot that but I don't look when people cross post. Knowing what data and dates are being used is key to this.
 
Upvote 0
If you are using the test file that you posted in your cross post then your selling dates are all 2024 and your buying dates are all 2025,
Click to expand...
this is my bad !
but in here this is the same year.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Change calculation by insert new column for two sheets for separated ranges
Replies
2
Views
74
abdo meghari
A
A
  • Solved
compare brands between two sheets and show minus and positive values based on date (today)
Replies
6
Views
278
abdo meghari
A
A
  • Solved
Delete first and last item for each cell in the same column for two sheets
2 3 4
Replies
38
Views
841
Peter_SSs
Peter_SSs
A
  • Solved
transpose data for each sheet based on multiple prices
2
Replies
10
Views
428
abdo meghari
A
A
  • Question Question
populate & update invoice information across sheets based on invoice number
Replies
0
Views
375
abdo meghari
A

Forum statistics

Threads
1,226,827
Messages
6,193,179
Members
453,778
Latest member
RDJones45

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