Copy or Shift row values horizontally wrt first row value.

Some videos you may like

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

ukbulldog001

New Member
Joined
Jul 8, 2015
Messages
15
Here after long time.
Sorry for link
below is table 1
Excel 2016 (Windows) 32 bit
A
B
C
1
CHARLIST-ALIST-B
2
ABCTBA-001TBD-001
3
ABCTBA-002TBD-002
4
ABCTBA-003TBD-003
5
ABCTBA-004TBD-004
6
ABCTBA-005TBD-005
7
DEFTBA-006TBD-006
8
DEFTBA-007TBD-007
9
DEFTBA-008TBD-008
10
GHITBA-009TBD-009
11
GHITBA-010TBD-010
Sheet: Sheet1

and below is table 2 which is the expected result.

Excel 2016 (Windows) 32 bit
F
G
H
I
J
K
L
M
N
O
P
1
CHARLIST-ALIST-BLIST-A1LIST-B1LIST-A2LIST-B2LIST-A3LIST-B3LIST-A4LIST-B4
2
ABCTBA-001TBD-001TBA-002TBD-002TBA-003TBD-003TBA-004TBD-004TBA-005TBD-005
3
DEFTBA-006TBD-006TBA-007TBD-007TBA-008TBD-008
4
GHITBA-009TBD-009TBA-010TBD-010
Sheet: Sheet1
 

Marcelo Branco

MrExcel MVP
Joined
Aug 23, 2010
Messages
16,393
Maybe this macro

Code:
Sub aTest()
    Dim dic As Object, vData As Variant, i As Long
    Dim vKey As Variant, lNumItems As Long, strItem As String
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    
    vData = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
    'Stores values in the dictionary
    For i = LBound(vData) To UBound(vData)
        If dic.exists(vData(i, 1)) Then
            dic(vData(i, 1))(vData(i, 2)) = Empty
            dic(vData(i, 1))(vData(i, 3)) = Empty
        Else
            Set dic(vData(i, 1)) = CreateObject("Scripting.Dictionary")
            dic(vData(i, 1))(vData(i, 2)) = Empty
            dic(vData(i, 1))(vData(i, 3)) = Empty
        End If
    Next i
    
    'Transfer values to worksheet beginning in G2
    i = 1
    For Each vKey In dic.keys
        If dic(vKey).Count > lNumItems Then lNumItems = dic(vKey).Count
        i = i + 1
        Range("G" & i).Resize(, dic(vKey).Count) = dic(vKey).keys
    Next vKey
    
    'Headers
    Range("F1") = "CHAR"
    Range("F2").Resize(dic.Count) = Application.Transpose(dic.keys)
    For i = 1 To lNumItems
        strItem = "LIST-B"
        If i Mod 2 = 1 Then strItem = "LIST-A"
        If i > 2 Then strItem = strItem & Int((i - 1) / 2)
        Range("G1").Offset(, i - 1) = strItem
    Next i
End Sub

Hope this helps

M.
 

ukbulldog001

New Member
Joined
Jul 8, 2015
Messages
15
Maybe this macro

Code:
Sub aTest()
    Dim dic As Object, vData As Variant, i As Long
    Dim vKey As Variant, lNumItems As Long, strItem As String
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    
    vData = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
    'Stores values in the dictionary
    For i = LBound(vData) To UBound(vData)
        If dic.exists(vData(i, 1)) Then
            dic(vData(i, 1))(vData(i, 2)) = Empty
            dic(vData(i, 1))(vData(i, 3)) = Empty
        Else
            Set dic(vData(i, 1)) = CreateObject("Scripting.Dictionary")
            dic(vData(i, 1))(vData(i, 2)) = Empty
            dic(vData(i, 1))(vData(i, 3)) = Empty
        End If
    Next i
    
    'Transfer values to worksheet beginning in G2
    i = 1
    For Each vKey In dic.keys
        If dic(vKey).Count > lNumItems Then lNumItems = dic(vKey).Count
        i = i + 1
        Range("G" & i).Resize(, dic(vKey).Count) = dic(vKey).keys
    Next vKey
    
    'Headers
    Range("F1") = "CHAR"
    Range("F2").Resize(dic.Count) = Application.Transpose(dic.keys)
    For i = 1 To lNumItems
        strItem = "LIST-B"
        If i Mod 2 = 1 Then strItem = "LIST-A"
        If i > 2 Then strItem = strItem & Int((i - 1) / 2)
        Range("G1").Offset(, i - 1) = strItem
    Next i
End Sub

Hope this helps

M.

Worked like charm, thanks a lot
 

ukbulldog001

New Member
Joined
Jul 8, 2015
Messages
15

ADVERTISEMENT

Maybe this macro

Code:
Sub aTest()
    Dim dic As Object, vData As Variant, i As Long
    Dim vKey As Variant, lNumItems As Long, strItem As String
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    
    vData = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
    'Stores values in the dictionary
    For i = LBound(vData) To UBound(vData)
        If dic.exists(vData(i, 1)) Then
            dic(vData(i, 1))(vData(i, 2)) = Empty
            dic(vData(i, 1))(vData(i, 3)) = Empty
        Else
            Set dic(vData(i, 1)) = CreateObject("Scripting.Dictionary")
            dic(vData(i, 1))(vData(i, 2)) = Empty
            dic(vData(i, 1))(vData(i, 3)) = Empty
        End If
    Next i
    
    'Transfer values to worksheet beginning in G2
    i = 1
    For Each vKey In dic.keys
        If dic(vKey).Count > lNumItems Then lNumItems = dic(vKey).Count
        i = i + 1
        Range("G" & i).Resize(, dic(vKey).Count) = dic(vKey).keys
    Next vKey
    
    'Headers
    Range("F1") = "CHAR"
    Range("F2").Resize(dic.Count) = Application.Transpose(dic.keys)
    For i = 1 To lNumItems
        strItem = "LIST-B"
        If i Mod 2 = 1 Then strItem = "LIST-A"
        If i > 2 Then strItem = strItem & Int((i - 1) / 2)
        Range("G1").Offset(, i - 1) = strItem
    Next i
End Sub

Hope this helps

M.


There 1 tiny problem.
if the table is as below

Excel 2016 (Windows) 32 bit
A
B
C
1
CHARLIST-ALIST-B
2
XYZTBA-01TBD-01
3
XYZTBA-02TBD-02
4
XYZTBA-03TBD-03
5
XYZTBA-03TBD-03
6
XYZTBA-05TBD-05
7
XYZTBA-05TBD-07
Sheet: Sheet1

i want it to be as it is like below table

Excel 2016 (Windows) 32 bit
F
G
H
I
J
K
L
M
N
O
P
Q
R
1
CHARLIST-ALIST-BLIST-A1LIST-B1LIST-A2LIST-B2LIST-A3LIST-B3LIST-A4LIST-B4LIST-A5LIST-B5
2
XYZTBA-01TBD-01TBA-02TBD-02TBA-03TBD-03TBA-03TBD-03TBA-05TBD-05TBA-05TBD-07
Sheet: Sheet1

Just want it to be without any consolidation.
Appritiate the help.
Thanks is advance.
 

Marcelo Branco

MrExcel MVP
Joined
Aug 23, 2010
Messages
16,393
Try this new version

Code:
Sub aTestV2()
    Dim dic As Object, vData As Variant, i As Long, spl As Variant
    Dim vKey As Variant, lNumItems As Long, strItem As String
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    
    vData = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
    'Stores values in the dictionary
    For i = LBound(vData) To UBound(vData)
            dic(vData(i, 1)) = dic(vData(i, 1)) & "," & vData(i, 2) & "," & vData(i, 3)
    Next i
    
    'Transfer values to worksheet beginning in G2
    i = 1
    For Each vKey In dic.keys
        spl = Split(Mid(dic(vKey), 2), ",")
        If UBound(spl) + 1 > lNumItems Then lNumItems = UBound(spl) + 1
        i = i + 1
        Range("G" & i).Resize(, UBound(spl) + 1) = spl
    Next vKey
    
    'Headers
    Range("F1") = "CHAR"
    Range("F2").Resize(dic.Count) = Application.Transpose(dic.keys)
    For i = 1 To lNumItems
        strItem = "LIST-B"
        If i Mod 2 = 1 Then strItem = "LIST-A"
        If i > 2 Then strItem = strItem & Int((i - 1) / 2)
        Range("G1").Offset(, i - 1) = strItem
    Next i
End Sub

M.
 

ukbulldog001

New Member
Joined
Jul 8, 2015
Messages
15
Try this new version

Code:
Sub aTestV2()
    Dim dic As Object, vData As Variant, i As Long, spl As Variant
    Dim vKey As Variant, lNumItems As Long, strItem As String
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    
    vData = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
    'Stores values in the dictionary
    For i = LBound(vData) To UBound(vData)
            dic(vData(i, 1)) = dic(vData(i, 1)) & "," & vData(i, 2) & "," & vData(i, 3)
    Next i
    
    'Transfer values to worksheet beginning in G2
    i = 1
    For Each vKey In dic.keys
        spl = Split(Mid(dic(vKey), 2), ",")
        If UBound(spl) + 1 > lNumItems Then lNumItems = UBound(spl) + 1
        i = i + 1
        Range("G" & i).Resize(, UBound(spl) + 1) = spl
    Next vKey
    
    'Headers
    Range("F1") = "CHAR"
    Range("F2").Resize(dic.Count) = Application.Transpose(dic.keys)
    For i = 1 To lNumItems
        strItem = "LIST-B"
        If i Mod 2 = 1 Then strItem = "LIST-A"
        If i > 2 Then strItem = strItem & Int((i - 1) / 2)
        Range("G1").Offset(, i - 1) = strItem
    Next i
End Sub

M.

Now that works well...
Thanks a lot M
 

Watch MrExcel Video

Forum statistics

Threads
1,109,341
Messages
5,528,147
Members
409,804
Latest member
aceyus_michael

This Week's Hot Topics

  • Change military grades into rank
    Afternoon all Need help with formula that will change military rank (i.e. 1, 2, 3 into Amn, A1C, SrA). Running IF formula that does not work...
  • VBA COUNTIF SOLUTION
    Hi The following are the errors spread across the several columns from E to Q ie. 13 columns across several sheets with more than 500 rows per...
  • INSERT ROW WITH SPECIFIS TEXT IN A COLUMN
    Hi All! How can identify that that the row to be inserted has to be inserted before 1st row with specific text in column F. If I record the...
  • Auto-Create a monthly Sign in sheet for preschool students
    The image below is what each page looks like. Above is space for the "Child Name" "Month" "Class" School days are obviously Monday-Friday but...
  • VBA vlookup multiple results
    Hi folks, Hopefully someone out there can help. I have a list to vlookup which works (ish). the lookup only picks up the first instance of the...
  • Extract values for earliest/latest times
    I am trying to put together a formula to get the earliest start time, the latest end time from column A for each person in Column B-F without the...
Top