Copy or Shift row values horizontally wrt first row value.

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
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
 
Upvote 0
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.
 
Upvote 0
Marcelo Branco said:
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.
Click to expand...

Worked like charm, thanks a lot
 
Upvote 0
Marcelo Branco said:
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.
Click to expand...


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.
 
Upvote 0
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.
 
Upvote 0
Marcelo Branco said:
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.
Click to expand...

Now that works well...
Thanks a lot M
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
Using Vlookup or Index/Match across 2 workbooks
Replies
1
Views
162
DataKnight
D
Yecart77
  • Solved
Data consolidation within a table
Replies
4
Views
148
Yecart77
Yecart77
N
  • Solved
Pulling certain row values if a number is matched
Replies
2
Views
150
Newbie73
N
S
  • Question
Repeating a pivot table many times and changing only one column -- are there more efficient approaches?
Replies
0
Views
145
sschaefer
S
A
  • Solved
Need VBA to automatically copy paste rows based factory selected
Replies
8
Views
138
Alex Blakenburg
A

Forum statistics

Threads
1,214,591
Messages
6,120,426
Members
448,961
Latest member
nzskater

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