Modidicar macro para que ordene de manera especifica
Tengonla siguiente macro que me arroja los resultados de manera alfabética
Pero necesito los resultados en elnsiguiente orden
BETI JAI
PASTAS
LIGHT
CLÁSICO
PBT JAMÓN Y QUESO
Sub PasarDatos()
'Por Dante Amor
Dim i As Long, j As Long, k As Long, n As Long, nmax As Long
Dim a As Variant, b As Variant, ky As Variant
Dim sh1 As Worksheet, sh2 As Worksheet
Dim cad As String
Dim dic As Object
Dim rng As Range
'
Application.ScreenUpdating = False
'
Set sh1 = Sheets("Respuestas de formulario 1")
Set sh2 = Sheets("Cembrass")
Set dic = CreateObject("Scripting.Dictionary")
Set rng = sh1.Range("A1:F" & sh1.Range("A" & Rows.Count).End(3).Row)
'
If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
a = rng.Value
ReDim b(1 To UBound(a, 1) * 4, 1 To 5)
sh2.Rows("4:" & Rows.Count).Clear
dic.CompareMode = vbTextCompare
'
For j = 2 To UBound(a, 2) 'ciclo de columnas de B a F
For i = 2 To UBound(a, 1) 'ciclo de filas de 2 en adelante
If a(i, j) <> "" Then
If InStr(1, a(i, j), ":") > 0 Then
cad = Split(a(i, j), ":")(0)
Else
cad = a(i, j)
End If
dic(cad) = Empty
End If
Next
Next
'
k = 4
For Each ky In dic.keys
nmax = 0
For j = 2 To UBound(a, 2) 'ciclo de columnas de B a F
rng.AutoFilter j, ky & "*"
n = sh1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If n > nmax Then nmax = n
If j = 2 Then
With sh2.Cells(k, j)
.Value = ky
.Resize(1, 5).HorizontalAlignment = xlCenter
.Resize(1, 5).MergeCells = True
End With
End If
sh2.Cells(k + 1, j).Value = n
sh1.AutoFilter.Range.Columns(1).Offset(1).Copy sh2.Cells(k + 2, j)
sh1.ShowAllData
Next
k = k + nmax + 2
Next
sh2.Range("B4:F" & k - 1).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
1 Respuesta
Respuesta de Dante Amor
4
Primero, en la hoja "Respuestas de formulario 1", en la columna K desde la fila 2 y hacia abajo escribe las palabras y el orden en que quieres los resultados.
Nota: Es importante que las palabras estén escritas exactamente como está en la hoja.
Ejemplo:
Prueba la siguiente macro:
Sub PasarDatos()
'Por Dante Amor
Dim i As Long, j As Long, k As Long, n As Long, nmax As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Dim c As Range
'
Application.ScreenUpdating = False
'
Set sh1 = Sheets("Respuestas de formulario 1")
Set sh2 = Sheets("Cembrass")
'
If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
sh2.Rows("4:" & Rows.Count).Clear
'
k = 4
For Each c In sh1.Range("K2", sh1.Range("K" & Rows.Count).End(3))
nmax = 0
For j = 2 To Columns("F").Column 'ciclo de columnas de B a F
sh1.Range("A1:F" & sh1.Range("A" & Rows.Count).End(3).Row).AutoFilter j, c.Value & "*"
n = sh1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If n > nmax Then nmax = n
If j = 2 Then
With sh2.Cells(k, j)
.Value = c.Value
.Resize(1, 5).HorizontalAlignment = xlCenter
.Resize(1, 5).MergeCells = True
End With
End If
sh2.Cells(k + 1, j).Value = n
sh1.AutoFilter.Range.Columns(1).Offset(1).Copy sh2.Cells(k + 2, j)
sh1.ShowAllData
Next
k = k + nmax + 2
Next
sh2.Range("B4:F" & k - 1).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub[Comenta cualquier duda.
Consulta la columna k la tengo ovuada con unas fórmulas. Se puede reemplazar K por O
Puedes utilizar cualquier columna disponible, solamente cambia en esta línea de la macro las "K" por la letra de la columna.
For Each c In sh1.Range("K2", sh1.Range("K" & Rows.Count).End(3))
