want to split data depends on multiple columns

Question

I want to split data on basis of A & B-column, if next row is same from A-column then look into B-column. if next row is same from B then copy F, G H-column till value from B is unchanged. Its very complicated to explain in words. that's why I have pasted snap of raw data & expected result. It would be very grateful if someone help me into this. Column A to H is raw data, From column-J is expected data. I have selected range of raw & result data in snap. We just have to paste values from F-column only once for unique value A.

Sub demo()
Dim lastrow As Integer, r As Integer, c As Integer, cot4 As Integer, r1 As Integer
r1 = 2

lastrow = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row

Dim r3 As Integer

c = 15

For r = 3 To lastrow + 1

If Worksheets("Sheet1").Cells(r, 2).Offset(0, 0) = Worksheets("Sheet1").Cells(r, 2).Offset(-1, 0) Then
        
    Worksheets("Sheet1").Cells(1, c) = Worksheets("Sheet1").Cells(r, 1)
    Worksheets("Sheet1").Cells(2, c) = Worksheets("Sheet1").Cells(r, 2)
    Worksheets("Sheet1").Cells(r1, c).Offset(1, 0) = Worksheets("Sheet1").Cells(r - 1, 7)
Else
    Worksheets("Sheet1").Cells(r, c) = Worksheets("Sheet1").Cells(r, 7).Offset(-1, 0)
    c = c + 1
   Worksheets("Sheet1").Cells(r, c) = Worksheets("Sheet1").Cells(r, 7)
    Worksheets("Sheet1").Cells(r1, c) = Worksheets("Sheet1").Cells(r - 1, 7)
   ' c = c + 1
    r1 = 1
  End If
  r1 = r1 + 1
  Next r
  Call mycode_to_merge
End Sub

Sub mycode_to_merge()

Range("O1").Select
Range(Selection, Selection.End(xlToRight)).Select

Application.DisplayAlerts = False

Dim rng As Range

MergeCells:

For Each rng In Selection

    If rng.Value = rng.Offset(0, 1).Value And rng.Value <> "" Then
        Range(rng, rng.Offset(0, 1)).merge
        Range(rng, rng.Offset(0, 1)).HorizontalAlignment = xlCenter
        Range(rng, rng.Offset(0, 1)).VerticalAlignment = xlCenter
        GoTo MergeCells
    End If
Next
End Sub

This code generates this result,

Don't have problem in above mycode_to_merge function.

Following is the Raw Data, need to split by space:

SVC_RA_CHT_NR   DEL_ZN_NR   FIX_VAR_MUL_CD  CTM_RA_CHT_MIN_QY   WGT_MS_UNT_TYP_CD   CTM_RA_CHT_MAX_QY   NCV_PKG_RA  RA_TYP_CD
1J1K2J  001             1   26.36   R
1J1K2J  001             2   26.91   R
1J1K2J  001             3   27.47   R
1J1K2J  001             10000000    0   P
1J1K2J  002             1   29.5    R
1J1K2J  002             2   30.93   R
1J1K2J  002             3   32.35   R
1J1K2J  002             10000000    0   P
1J1K2J  505             1   13.88   R
1J1K2J  505             2   0.65    R
1J1K2J  505             3   0.5 R
1J1K2J  505             10000000    0   P
1J1K2K  004             0.5 25.8    R
1J1K2K  004             1   28.63   R
1J1K2K  004             1.5 31.51   R
1J1K2K  004             65  150.51  R
1J1K2K  004             70  158.52  R
1J1K2K  004             10000000    2.26    M
1J1K2K  006             0.5 42.07   R
1J1K2K  006             1   46.63   R
1J1K2K  006             1.5 51.18   R
1J1K2K  006             65  244.06  R
1J1K2K  006             70  257.24  R
1J1K2K  006             10000000    3.67    M
1J1K2K  041             0.5 29.83   R
1J1K2K  041             1   32.04   R
1J1K2K  041             1.5 34.25   R
1J1K2K  041             65  156.3   R
1J1K2K  041             70  164.58  R
1J1K2K  041             10000000    2.35    M
1J1K2K  042             0.5 29.84   R
1J1K2K  042             1   32.93   R
1J1K2K  042             1.5 35.98   R
1J1K2K  042             65  177.15  R
1J1K2K  042             70  186.76  R
1J1K2K  042             10000000    2.66    M
1J1K2K  505             0.5 25.21   R
1J1K2K  505             1   28.13   R
1J1K2K  505             1.5 31.04   R
1J1K2K  505             65  144.24  R
1J1K2K  505             70  151.27  R
1J1K2K  505             10000000    2.15    M

Markdown format


SVC_RA_CHT_NR	DEL_ZN_NR	FIX_VAR_MUL_CD	CTM_RA_CHT_MIN_QY	WGT_MS_UNT_TYP_CD	CTM_RA_CHT_MAX_QY	NCV_PKG_RA	RA_TYP_CD
1J1K2J	001				1	26.36	R
1J1K2J	001				2	26.91	R
1J1K2J	001				3	27.47	R
1J1K2J	001				10000000	0	P
1J1K2J	002				1	29.5	R
1J1K2J	002				2	30.93	R
1J1K2J	002				3	32.35	R
1J1K2J	002				10000000	0	P
1J1K2J	505				1	13.88	R
1J1K2J	505				2	0.65	R
1J1K2J	505				3	0.5	R
1J1K2J	505				10000000	0	P
1J1K2K	004				0.5	25.8	R
1J1K2K	004				1	28.63	R
1J1K2K	004				1.5	31.51	R
1J1K2K	004				65	150.51	R
1J1K2K	004				70	158.52	R
1J1K2K	004				10000000	2.26	M
1J1K2K	006				0.5	42.07	R
1J1K2K	006				1	46.63	R
1J1K2K	006				1.5	51.18	R
1J1K2K	006				65	244.06	R
1J1K2K	006				70	257.24	R
1J1K2K	006				10000000	3.67	M
1J1K2K	041				0.5	29.83	R
1J1K2K	041				1	32.04	R
1J1K2K	041				1.5	34.25	R
1J1K2K	041				65	156.3	R
1J1K2K	041				70	164.58	R
1J1K2K	041				10000000	2.35	M
1J1K2K	042				0.5	29.84	R
1J1K2K	042				1	32.93	R
1J1K2K	042				1.5	35.98	R
1J1K2K	042				65	177.15	R
1J1K2K	042				70	186.76	R
1J1K2K	042				10000000	2.66	M
1J1K2K	505				0.5	25.21	R
1J1K2K	505				1	28.13	R
1J1K2K	505				1.5	31.04	R
1J1K2K	505				65	144.24	R
1J1K2K	505				70	151.27	R
1J1K2K	505				10000000	2.15	M

Please add a data sample as text which can be copy/pasted. See Why should I not upload images of code/data/errors when asking a question? — Ron Rosenfeld
– Ron Rosenfeld, Commented Jun 15 at 10:36
This looks odd Worksheets("Sheet1").Cells(r, c) = .. since you are writing to column c then the row counter should be r1 — CDP1802
– CDP1802, Commented Jun 15 at 10:38

CDP1802 · Accepted Answer · 2025-06-26 14:50:32Z

2

Using a dictionary and collections

edit1 - check on F and H values

edit2 - create new sheets beyond XFD

Sub processX()

    Dim ws As Worksheet, dict, k1, k2, ar, v
    Dim lastrow As Long, i As Long, c As Long, r As Long, n As Long
    Dim a As String, b As String
    
    Set dict = CreateObject("Scripting.Dictionary")
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' input
    With ws
        .Columns("M:XFD").Delete
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        ar = .Range("A2:H" & lastrow)
       
        For i = 1 To UBound(ar)
            a = Trim(ar(i, 1))
            b = Trim(ar(i, 2))
            
            If Not dict.exists(a) Then
                dict.Add a, CreateObject("Scripting.Dictionary")
            End If
            
            If Not dict(a).exists(b) Then
                dict(a).Add b, New Collection
            End If
            
            dict(a)(b).Add i
        Next
    End With
    
    ' output
    c = 13 ' m
    For Each k1 In dict.keys
    
        ' create new sheet if exceeds XFD
        If c + 3 + dict(k1).Count > ws.Columns.Count Then
            Set ws = ThisWorkbook.Sheets.Add(After:=ws)
            c = 13
        End If
    
       ws.Cells(1, c) = k1
       n = 1
       For Each k2 In dict(k1).keys
            n = n + 1
            ws.Cells(2, c + n).NumberFormat = "@"
            ws.Cells(2, c + n) = k2
            
            ' values
            r = 3
            For Each v In dict(k1)(k2)
                If n = 2 Then
                    ws.Cells(r, c) = ar(v, 6) ' col F
                    ws.Cells(r, c + 1) = ar(v, 8) ' col H
                Else
                    ' check all rows have same F H values
                    If ws.Cells(r, c) <> ar(v, 6) _
                      Or ws.Cells(r, c + 1) <> ar(v, 8) Then
                      
                        MsgBox "Mismatch col F or H row " & v + 1, vbExclamation
                        Exit Sub
                        
                    End If
                      
                End If
                ws.Cells(r, c + n) = ar(v, 7) ' col G
                r = r + 1
            Next
       Next
       
       ' format header
       With ws.Cells(1, c).Resize(, n + 1)
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Interior.Color = RGB(220, 220, 255)
            .Font.Bold = True
       End With
       c = c + n + 2
    Next
    MsgBox UBound(ar) & " rows processed", vbInformation
End Sub

edited Jun 26 at 14:50

answered Jun 15 at 15:28

CDP1802

17.3k2 gold badges10 silver badges19 bronze badges

Sign up to request clarification or add additional context in comments.

9 Comments

Cristian Buse Jun 20 at 12:15

VBA-FastDictionary can replace chained calls like If Not dict(...).Exists(...) Then dict.Add ... with dict.Add Key, Item, IgnoreErrors:=True :). Works on Mac, is fully compatible with scripting but also has cool stuff like speed and additional methods

Swapnil Supekar Jun 26 at 11:41

Excel is limiting me till XFD column, can u please suggest how to add columns accordingly

Swapnil Supekar Jun 26 at 11:53

I have more than 10 lacs rows, resulted in 5 lac+ columns. so what changes should i done in above code, so that columns will not be insufficient.

CDP1802 Jun 26 at 12:14

@SwapnilSupekar Can you split the data into 2 or more smaller workbooks ?

Swapnil Supekar Jun 26 at 13:40

Yes, but how to do that too?

Swapnil Supekar Jun 26 at 13:51

May be i need more than 2-3 sheets. Can we add new sheets if column limits exceeded.

|

user22566114 · Accepted Answer · 2025-06-15 16:00:15Z

I know that your question has tags VBA and Excel 2010 but since you've bought a Microsoft lisence you can log on to your Microsoft account and apply the latest functions in Excel online. I have bought Excel 2013 approx. 10 years ago and i can work with Excel online and use the newest functions.

=DROP(IFNA(REDUCE("",UNIQUE(A2:A65),LAMBDA(u,v,
HSTACK(u,LET(
filtered_svc,FILTER(A2:H65,A2:A65=v),
ctm_ra,UNIQUE(CHOOSECOLS(filtered_svc,6,8)),
rows_del,ROWS(UNIQUE(FILTER(A2:B65,A2:A65=v))),
ncv,CHOOSECOLS(filtered_svc,7),
rows_ncv,ROWS(ncv),
ncv_full,WRAPCOLS(ncv,rows_ncv/rows_del),
IFNA(VSTACK(v,HSTACK("","",TOROW(UNIQUE(FILTER(B2:B65,A2:A65=v)))),
HSTACK(ctm_ra,ncv_full)),"")),""))),""),,1)

I have as well tried to find a VBA solution but only achieved a result that is similar to your goal but not exactly what you want.

Black cat · Accepted Answer · 2025-06-17 12:24:38Z

0

The mod. serves to check that a new SVC is detected.
The separatorBool marks this and according to it, restore the r loop variable from rbuff after copying the data from the 6th and 8th column.

The copycol variable contains the column number to copy.
A little bit changed the relations in the IF statements.
Also keep the functionality of the mycode_to_merge Sub

Sub demo()
Dim lastrow As Integer, r As Integer, c As Integer, cot4 As Integer, r1 As Integer
r1 = 3

lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

Dim r3 As Integer

c = 14
For r = 2 To lastrow + 1


If Worksheets("Sheet1").Cells(r, 2) = Worksheets("Sheet1").Cells(r, 2).Offset(-1, 0) And _
Worksheets("Sheet1").Cells(r, 1) = Worksheets("Sheet1").Cells(r, 1).Offset(-1, 0) Then  'to avoid same data in Column B while Column A is different
    Worksheets("Sheet1").Cells(r1, c) = Worksheets("Sheet1").Cells(r, copycol)
    If separatorBool Then
        Worksheets("Sheet1").Cells(r1, c + 1) = Worksheets("Sheet1").Cells(r, copycol + 2)  'data for RA
    End If
Else
    If Worksheets("Sheet1").Cells(r, 1) <> Worksheets("Sheet1").Cells(r, 1).Offset(-1, 0) Then
      'c = c + 1
      copycol = 6
      separatorBool = True
      rbuff = r
    Else
      If separatorBool Then copycol = 7: r = rbuff: c = c + 1
      separatorBool = False
    End If
    c = c + 1
    If Not separatorBool Then
        Worksheets("Sheet1").Cells(2, c) = Worksheets("Sheet1").Cells(r, 2)
    End If
    r1 = 3
    Worksheets("Sheet1").Cells(1, c) = Worksheets("Sheet1").Cells(r, 1)  'header for SVC 
    Worksheets("Sheet1").Cells(1, c + 1) = Worksheets("Sheet1").Cells(r, 1)  'header for RA
    Worksheets("Sheet1").Cells(r1, c) = Worksheets("Sheet1").Cells(r, copycol)
    If separatorBool Then
        Worksheets("Sheet1").Cells(r1, c + 1) = Worksheets("Sheet1").Cells(r, copycol + 2)
    End If
    'Worksheets("Sheet1").Cells(r, c) = Worksheets("Sheet1").Cells(r, 7)
    'Worksheets("Sheet1").Cells(r1, c) = Worksheets("Sheet1").Cells(r - 1, 7)
    'c = c + 1
End If
r1 = r1 + 1

Next r


  Call mycode_to_merge
End Sub

This is the result table fro the first 40 rows of data

edited Jun 17 at 12:24

answered Jun 15 at 16:15

Black cat

7,6358 gold badges67 silver badges99 bronze badges

4 Comments

CDP1802 Jun 15 at 18:36

Try with B20:B23 = 004

Black cat Jun 17 at 12:36

Thanks for the bug. Updated the code.

Swapnil Supekar Jun 16 at 3:33

getting error in copycol

Black cat Jun 17 at 12:34

If you use Option Explicit you have to declare (Dim) every variable. Your code doesn't show it. Since you declare other variables as Integer the type depends on you. If not use Option Explicit variables are default declared as Variant type. Declare the 3 new variable separatorBool as Boolean, and copycol and rbuff as your code and data range require: Integer, Long, or Double

Collectives™ on Stack Overflow

want to split data depends on multiple columns

3 Answers 3

9 Comments

Comments

4 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

9 Comments

Comments

4 Comments

Your Answer

Sign up or log in

Post as a guest

Related