VBA TRANSPOSE DICTIONARY & ARRAY

R

roykana

Active Member
Joined
Mar 8, 2018
Messages
311
Office Version
  1. 2010
Platform
  1. Windows
Dear All master,

I want to make transpose with vba code dictionary and array because the number of rows or records is 10,000.

The sheet name is "MASTER" and is it possible to directly transpose on the same sheet and create a table directly?
this is original data

VBA TRANSPOSE DICTIONARY & ARRAY.xlsx
ABCDE
1PATHFILENAMEKODEITEMV
2\\server-pc\CATALOG\CATALOG TAS FINAL\111138(1).jpg111138(1).jpg111138TAMAKA R 111138 RC/L-TOP
3\\server-pc\CATALOG\CATALOG TAS FINAL\111138(2).jpg111138(2).jpg111138TAMAKA R 111138 RC/L-TOP
4\\server-pc\CATALOG\CATALOG TAS FINAL\111138(3).jpg111138(3).jpg111138TAMAKA R 111138 RC/L-TOP
5\\server-pc\CATALOG\CATALOG TAS FINAL\111138(4).jpg111138(4).jpg111138TAMAKA R 111138 RC/L-TOP
6\\server-pc\CATALOG\CATALOG TAS FINAL\111138(5).jpg111138(5).jpg111138TAMAKA R 111138 RC/L-TOP
7\\server-pc\CATALOG\CATALOG TAS FINAL\111138(6).jpg111138(6).jpg111138TAMAKA R 111138 RC/L-TOP
8\\server-pc\CATALOG\CATALOG TAS FINAL\Other\.139.jpg.139.jpg.139ALFIN R 139 RKL
9\\server-pc\CATALOG\CATALOG TAS FINAL\Other\+112.jpg+112.jpg+112AKZ RMJ C 112
10\\server-pc\CATALOG\CATALOG TAS FINAL\ENTOS\57024.jpg57024.jpg57024ALFON PKN 57024 D1680 TG
11\\server-pc\CATALOG\CATALOG TAS FINAL\ENTOS\57024-1.jpg57024-1.jpg57024ALFON PKN 57024 D1680 TG
12\\server-pc\CATALOG\CATALOG TAS FINAL\1040F...jpg1040F...jpg1040F..SPLASH R 1040 PRINT FROZEN
MASTER


this is the desired data result
VBA TRANSPOSE DICTIONARY & ARRAY.xlsx
ABCDEFGHIJKLMNO
1PATH1PATH2PATH3PATH4PATH5PATH6FILENAME1FILENAME2FILENAME3FILENAME4FILENAME5FILENAME6KODEITEMV
2\\server-pc\CATALOG\CATALOG TAS FINAL\111138(1).jpg\\server-pc\CATALOG\CATALOG TAS FINAL\111138(2).jpg\\server-pc\CATALOG\CATALOG TAS FINAL\111138(3).jpg\\server-pc\CATALOG\CATALOG TAS FINAL\111138(4).jpg\\server-pc\CATALOG\CATALOG TAS FINAL\111138(5).jpg\\server-pc\CATALOG\CATALOG TAS FINAL\111138(6).jpg111138(1).jpg111138(2).jpg111138(3).jpg111138(4).jpg111138(5).jpg111138(6).jpg111138TAMAKA R 111138 RC/L-TOP
3\\server-pc\CATALOG\CATALOG TAS FINAL\Other\.139.jpg.139.jpg.139ALFIN R 139 RKL
4\\server-pc\CATALOG\CATALOG TAS FINAL\Other\+112.jpg+112.jpg+112AKZ RMJ C 112
5\\server-pc\CATALOG\CATALOG TAS FINAL\ENTOS\57024.jpg\\server-pc\CATALOG\CATALOG TAS FINAL\ENTOS\57024-1.jpg57024.jpg57024-1.jpg57024ALFON PKN 57024 D1680 TG
6\\server-pc\CATALOG\CATALOG TAS FINAL\1040F...jpg1040F...jpg1040F..SPLASH R 1040 PRINT FROZEN
MASTER (2)



thanks
roykana
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
Try this. Your data on MASTER sheet, results on MASTER2 sheet.

VBA Code: 
Sub TRANSPOSE_DATA()
  Dim i As Long, j As Long, k As Long, m As Long, lr As Long
  Dim a As Variant, b As Variant
  Dim sh As Worksheet
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh = Sheets("MASTER")
  lr = sh.Range("C" & Rows.Count).End(3).Row
  m = Evaluate(Replace("=MAX(COUNTIF(@,@))", "@", sh.Name & "!C2:C" & lr))  'maximo un valor unico
  a = sh.Range("A2:E" & lr).Value
  ReDim b(1 To UBound(a, 1), 1 To (m * 2) + 3)
  
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 3)) Then
      j = j + 1
      k = 1
      b(j, (m * 2) + 1) = a(i, 3) 'kode
      b(j, (m * 2) + 2) = a(i, 4) 'item
      b(j, (m * 2) + 3) = a(i, 5) 'v
    Else
      j = Split(dic(a(i, 3)), "|")(0)
      k = Split(dic(a(i, 3)), "|")(1) + 1
    End If
    dic(a(i, 3)) = j & "|" & k
    b(j, k) = a(i, 1)             'path
    b(j, k + m) = a(i, 2)         'name
  Next
  With Sheets("MASTER2")
    For i = 1 To m
      .Cells(1, i).Value = "PATH" & i
      .Cells(1, m + i).Value = "FILENAME" & i
      .Cells(1, m * 2 + 1).Resize(, 3).Value = sh.Range("C1:E1").Value
    Next
    .Range("A2").Resize(dic.Count, UBound(b, 2)).Value = b
  End With
End Sub
 
Upvote 0
DanteAmor said:
Try this. Your data on MASTER sheet, results on MASTER2 sheet.

VBA Code: 
Sub TRANSPOSE_DATA()
  Dim i As Long, j As Long, k As Long, m As Long, lr As Long
  Dim a As Variant, b As Variant
  Dim sh As Worksheet
  Dim dic As Object
 
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh = Sheets("MASTER")
  lr = sh.Range("C" & Rows.Count).End(3).Row
  m = Evaluate(Replace("=MAX(COUNTIF(@,@))", "@", sh.Name & "!C2:C" & lr))  'maximo un valor unico
  a = sh.Range("A2:E" & lr).Value
  ReDim b(1 To UBound(a, 1), 1 To (m * 2) + 3)
 
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 3)) Then
      j = j + 1
      k = 1
      b(j, (m * 2) + 1) = a(i, 3) 'kode
      b(j, (m * 2) + 2) = a(i, 4) 'item
      b(j, (m * 2) + 3) = a(i, 5) 'v
    Else
      j = Split(dic(a(i, 3)), "|")(0)
      k = Split(dic(a(i, 3)), "|")(1) + 1
    End If
    dic(a(i, 3)) = j & "|" & k
    b(j, k) = a(i, 1)             'path
    b(j, k + m) = a(i, 2)         'name
  Next
  With Sheets("MASTER2")
    For i = 1 To m
      .Cells(1, i).Value = "PATH" & i
      .Cells(1, m + i).Value = "FILENAME" & i
      .Cells(1, m * 2 + 1).Resize(, 3).Value = sh.Range("C1:E1").Value
    Next
    .Range("A2").Resize(dic.Count, UBound(b, 2)).Value = b
  End With
End Sub
Click to expand...
Dear DanteAmor,

Thanks for your reply,
for the code column should result in sheet "master2" should be text.
first I tried 3585 filename but in sheet "master2" is only 2815 filename, second on the "master2" sheet what can directly create table and autofit.

Thanks
roykana
 
Upvote 0
roykana said:
first I tried 3585 filename but in sheet "master2" is only 2815 filename
Click to expand...
What do you mean 3585 filename?
Are they records or does a single kode have 3585 versions?

roykana said:
sheet what can directly create table and autofit.
Click to expand...
Try this:
VBA Code: 
Sub TRANSPOSE_DATA()
  Dim i As Long, j As Long, k As Long, m As Long, lr As Long
  Dim a As Variant, b As Variant
  Dim sh As Worksheet
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh = Sheets("MASTER")
  lr = sh.Range("A" & Rows.Count).End(3).Row
  m = Evaluate(Replace("=MAX(COUNTIF(@,@))", "@", sh.Name & "!C2:C" & lr))  'maximo un valor unico
  a = sh.Range("A2:E" & lr).Value2
  ReDim b(1 To UBound(a, 1), 1 To (m * 2) + 3)
  
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 3)) Then
      j = j + 1
      k = 1
      b(j, (m * 2) + 1) = "'" & a(i, 3) 'kode
      b(j, (m * 2) + 2) = a(i, 4) 'item
      b(j, (m * 2) + 3) = a(i, 5) 'v
    Else
      j = Split(dic(a(i, 3)), "|")(0)
      k = Split(dic(a(i, 3)), "|")(1) + 1
    End If
    dic(a(i, 3)) = j & "|" & k
    b(j, k) = a(i, 1)             'path
    b(j, k + m) = a(i, 2)         'name
  Next
  With Sheets("MASTER2")
    .Cells.Clear
    For i = 1 To m
      .Cells(1, i).Value = "PATH" & i
      .Cells(1, m + i).Value = "FILENAME" & i
      .Cells(1, m * 2 + 1).Resize(, 3).Value = sh.Range("C1:E1").Value
    Next
    .Range("A2").Resize(dic.Count, UBound(b, 2)).Value = b
    .ListObjects.Add(xlSrcRange, .Range("$A$1", .Cells(dic.Count + 1, UBound(b, 2))), , xlYes).Name = "Table1"
    .Cells.EntireColumn.AutoFit
  End With
End Sub
 
Upvote 0
DanteAmor said:
What do you mean 3585 filename?
Are they records or does a single kode have 3585 versions?


Try this:
VBA Code: 
Sub TRANSPOSE_DATA()
  Dim i As Long, j As Long, k As Long, m As Long, lr As Long
  Dim a As Variant, b As Variant
  Dim sh As Worksheet
  Dim dic As Object
 
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh = Sheets("MASTER")
  lr = sh.Range("A" & Rows.Count).End(3).Row
  m = Evaluate(Replace("=MAX(COUNTIF(@,@))", "@", sh.Name & "!C2:C" & lr))  'maximo un valor unico
  a = sh.Range("A2:E" & lr).Value2
  ReDim b(1 To UBound(a, 1), 1 To (m * 2) + 3)
 
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 3)) Then
      j = j + 1
      k = 1
      b(j, (m * 2) + 1) = "'" & a(i, 3) 'kode
      b(j, (m * 2) + 2) = a(i, 4) 'item
      b(j, (m * 2) + 3) = a(i, 5) 'v
    Else
      j = Split(dic(a(i, 3)), "|")(0)
      k = Split(dic(a(i, 3)), "|")(1) + 1
    End If
    dic(a(i, 3)) = j & "|" & k
    b(j, k) = a(i, 1)             'path
    b(j, k + m) = a(i, 2)         'name
  Next
  With Sheets("MASTER2")
    .Cells.Clear
    For i = 1 To m
      .Cells(1, i).Value = "PATH" & i
      .Cells(1, m + i).Value = "FILENAME" & i
      .Cells(1, m * 2 + 1).Resize(, 3).Value = sh.Range("C1:E1").Value
    Next
    .Range("A2").Resize(dic.Count, UBound(b, 2)).Value = b
    .ListObjects.Add(xlSrcRange, .Range("$A$1", .Cells(dic.Count + 1, UBound(b, 2))), , xlYes).Name = "Table1"
    .Cells.EntireColumn.AutoFit
  End With
End Sub
Click to expand...
Dear Mr. DanteAmor,

Thank you for your reply. I give an example for the filename problem I mean..

but I can't use x2bb because there is a maximum notification of 3000 rows.


in the excel file that I share there are 3559 filenames if I use transpose vba then the filename is only 2815
file excel
Thanks
roykana
 
Upvote 0
roykana said:
in the excel file that I share there are 3559 filenames if I use transpose vba then the filename is only 2815
Click to expand...
The macro had a problem, I already fixed it. Try this:

VBA Code: 
Sub TRANSPOSE_DATA()
  Dim i As Long, j As Long, k As Long, m As Long, n As Long, lr As Long
  Dim a As Variant, b As Variant
  Dim sh As Worksheet
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh = Sheets("MASTER")
  lr = sh.Range("A" & Rows.Count).End(3).Row
  m = Evaluate(Replace("=MAX(COUNTIF(@,@))", "@", sh.Name & "!C2:C" & lr))  'maximo un valor unico
  a = sh.Range("A2:E" & lr).Value2
  ReDim b(1 To UBound(a, 1), 1 To (m * 2) + 3)
  
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 3)) Then
      n = n + 1
      j = n
      k = 1
      b(j, (m * 2) + 1) = "'" & a(i, 3) 'kode
      b(j, (m * 2) + 2) = a(i, 4) 'item
      b(j, (m * 2) + 3) = a(i, 5) 'v
    Else
      j = Split(dic(a(i, 3)), "|")(0)
      k = Split(dic(a(i, 3)), "|")(1) + 1
    End If
    dic(a(i, 3)) = j & "|" & k
    b(j, k) = a(i, 1)             'path
    b(j, k + m) = a(i, 2)         'name
  Next
  With Sheets("MASTER2")
    .Cells.Clear
    For i = 1 To m
      .Cells(1, i).Value = "PATH" & i
      .Cells(1, m + i).Value = "FILENAME" & i
      .Cells(1, m * 2 + 1).Resize(, 3).Value = sh.Range("C1:E1").Value
    Next
    .Range("A2").Resize(dic.Count, UBound(b, 2)).Value = b
    .ListObjects.Add(xlSrcRange, .Range("$A$1", .Cells(dic.Count + 1, UBound(b, 2))), , xlYes).Name = "Table1"
    .Cells.EntireColumn.AutoFit
  End With
End Sub
 
Upvote 0
Solution
DanteAmor said:
The macro had a problem, I already fixed it. Try this:

VBA Code: 
Sub TRANSPOSE_DATA()
  Dim i As Long, j As Long, k As Long, m As Long, n As Long, lr As Long
  Dim a As Variant, b As Variant
  Dim sh As Worksheet
  Dim dic As Object
 
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh = Sheets("MASTER")
  lr = sh.Range("A" & Rows.Count).End(3).Row
  m = Evaluate(Replace("=MAX(COUNTIF(@,@))", "@", sh.Name & "!C2:C" & lr))  'maximo un valor unico
  a = sh.Range("A2:E" & lr).Value2
  ReDim b(1 To UBound(a, 1), 1 To (m * 2) + 3)
 
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 3)) Then
      n = n + 1
      j = n
      k = 1
      b(j, (m * 2) + 1) = "'" & a(i, 3) 'kode
      b(j, (m * 2) + 2) = a(i, 4) 'item
      b(j, (m * 2) + 3) = a(i, 5) 'v
    Else
      j = Split(dic(a(i, 3)), "|")(0)
      k = Split(dic(a(i, 3)), "|")(1) + 1
    End If
    dic(a(i, 3)) = j & "|" & k
    b(j, k) = a(i, 1)             'path
    b(j, k + m) = a(i, 2)         'name
  Next
  With Sheets("MASTER2")
    .Cells.Clear
    For i = 1 To m
      .Cells(1, i).Value = "PATH" & i
      .Cells(1, m + i).Value = "FILENAME" & i
      .Cells(1, m * 2 + 1).Resize(, 3).Value = sh.Range("C1:E1").Value
    Next
    .Range("A2").Resize(dic.Count, UBound(b, 2)).Value = b
    .ListObjects.Add(xlSrcRange, .Range("$A$1", .Cells(dic.Count + 1, UBound(b, 2))), , xlYes).Name = "Table1"
    .Cells.EntireColumn.AutoFit
  End With
End Sub
Click to expand...
Dear Mr. @DanteAmor,
Thanks for your reply. It went perfectly.
Thanks
roykana
 
Upvote 0
Anyone I want to ask why if I run your vba code from visual basic editor causes error 1004 while if I run from excel that is active do not cause errors?
 
Upvote 0
What line is highlighted when you run it from the vb editor and it errors out ?
When you run it from the editor, have you made the Workbook that you are actually trying to update the Active Workbook ?
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
get folder parent path and subfolder path in array
2
Replies
15
Views
1K
Peter_SSs
Peter_SSs
R
  • Question Question
LOOKUP IN VBA ARRAY AND DICTIONARY
Replies
7
Views
739
GlennUK
G
M
  • Solved
VBA Transpose data from one sheet into another
Replies
9
Views
575
madi1004
M
P
  • Question Question
Copying and transposing data from one worksheet to another
Replies
1
Views
437
jdellasala
J
H
  • Question Question
Macro Help - Open Multiple Text Files one at a time, import data, use vlook tu match data to another sheet
Replies
3
Views
2K
James Snyder
J

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

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