nahomi23
New Member
- Joined
- Mar 9, 2021
- Messages
- 7
- Office Version
- 365
- 2016
- Platform
- Windows
Hello,
I need your help to make a macro that does the following:
They give me the data in this way
And the macro should convert it like this
At the moment I have this as a code but it does not do me well
I would greatly appreciate your help
I need your help to make a macro that does the following:
They give me the data in this way
Categoría 1 |
a |
b |
c |
d |
b1 |
c1 |
d1 |
b1 |
c1 |
d1 |
Categoría 2 |
z |
w |
x |
y |
w1 |
x1 |
y1 |
w2 |
x2 |
y2 |
w3 |
x3 |
y3 |
w4 |
x4 |
y4 |
And the macro should convert it like this
Categoría 1 | a | b | c | d |
b1 | c1 | d1 | ||
Categoría 2 | z | w | x | y |
w1 | x1 | y1 | ||
w2 | x2 | y2 | ||
w3 | x3 | y3 | ||
w4 | x4 | y4 |
At the moment I have this as a code but it does not do me well
VBA Code:
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
I would greatly appreciate your help
Last edited by a moderator: