Macro that transposes the information as follows

Copper Contributor

Hello,
I need your help to make a macro that does the following,


They give me the data in this way (all this information is in column A):

Categoría 1
a
b
c
d
b1
c1
d1
b1
c1
d1
Categoría 2
z
w
x
y
xy
w1
x1
y1
w2
x2
y2
xy2
w3
x3
y3
w4
x4
y4
xy4

 

And the macro should convert it like this

 

Categoría 1abcd 
  b1c1d1 
Categoría 2zwxyxy
  w1x1y1 
  w2x2y2xy2
  w3x3y3 
  w4x4y4 

 

At the moment I have this code but it does not work well for me

Option Explicit
Option Base 1

Sub obtener()

Dim r As Range, fr%, cr%
Set r = Range("A1").CurrentRegion

Dim z As Object, zs$, M(1 To 5)
Set z = CreateObject("scripting.dictionary")
Dim K As New Collection, ks$, kn%


On Error Resume Next 'para la K
For fr = 1 To r.Rows.Count

zs = r(fr, 1).Row

If r(fr, 1) Like "PO=*" Then

ks = ""
For cr = 2 To 4
ks = ks & r(fr + cr, 1)
Next
K.Add ks, ks


If K.Count > kn Then
kn = K.Count
Else
fr = fr + 5
GoTo sigue
End If


M(1) = r(fr, 1)
fr = fr + 1
M(2) = r(fr, 1)
fr = fr + 1
M(3) = r(fr, 1)
fr = fr + 1
M(4) = r(fr, 1)
fr = fr + 1
M(5) = r(fr, 1)
z.Add zs, M()
Else
ks = ""
For cr = 0 To 2
ks = ks & r(fr + cr, 1)
Next
K.Add ks, ks

If K.Count > kn Then
kn = K.Count
Else
fr = fr + 2
GoTo sigue
End If

' zs = r(fr, 1).Row
M(1) = Empty
M(2) = Empty
M(3) = r(fr, 1)
fr = fr + 1
M(4) = r(fr, 1)
fr = fr + 1
M(5) = r(fr, 1)
z.Add zs, M()
End If
sigue:
Next

Columns("C:J").ClearContents
Range("C2").Resize(z.Count, 5) = Application.Index(z.items, 0, 0)
End Sub

 

Which shows me the information in this way:

Categoría 1abc
  b1c1
Categoría 2zwx
  xyw1
  y1w2
  y2xy2
  x3y3
  x4y4

 

Could someone help me on how to do this macro

I would greatly appreciate your help!

0 Replies