Macro para ordenar datos con VBA─EXCEL
Tengo una tarea que se repite todos los días y lo que hace mi macro es extraer una tabla desde ACCESS y la pega siempre en la celda E3 y luego de eso tengo que ordenar MANUALMENTE la información por grupos en base a la información del campo "Origen_Fuente" el cual siempre llegada ordenada. Y lo que quiero es que la información en automático se orden por cada grupo de "Origen_Fuente" con su respectivo encabezado que traje de Access y de ser posible que se realice una autosuma debajo de cada celda vacía del campo "Usuario" porque en un futuro en esa columna vendrán valores numéricos
Adjunto las imágenes de las tablas
TABLA SIN ORDENAR
TABLA ORDENADA
1 Respuesta
En la segunda tabla estás eliminando algunos registros, pero no tengo claro cuál es la regla para determinar cuáles se quedan y cuáles no.
Prueba la siguiente macro. Pone los encabezado (sin formato), los registros y la autosuma de los únicos.
Sub Macro1()
'Por.Dante Amor
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Variant, b As Variant
Dim i As Long, j As Long, k As Long
Dim ant1 As String, ant2 As String
Dim dic As Object
'
Set s1 = Sheets("Hoja4") 'origen
Set dic = CreateObject("scripting.dictionary")
'
a = s1.Range("E3:K" & s1.Range("E" & Rows.Count).End(3).Row).Value2
ReDim b(1 To UBound(a, 1) * 3, 1 To UBound(a, 2))
ant1 = a(2, 1)
ant2 = a(2, 1) & a(2, 2) & a(2, 3) & a(2, 7)
'encabezado
k = 1
For j = 1 To UBound(a, 2)
b(k, j) = a(1, j)
Next
'
For i = 2 To UBound(a, 1)
If ant1 <> a(i, 1) Then
'cuenta
k = k + 1
b(k, 2) = dic.Count
dic.RemoveAll
k = k + 3
'encabezado
For j = 1 To UBound(a, 2)
b(k, j) = a(1, j)
Next
End If
'
dic(a(i, 2)) = Empty
If ant2 <> a(i, 1) & a(i, 2) & a(i, 3) & a(i, 7) Then
k = k + 1
End If
For j = 1 To UBound(a, 2)
b(k, j) = a(i, j)
Next
'
ant1 = a(i, 1)
ant2 = a(i, 1) & a(i, 2) & a(i, 3) & a(i, 7)
Next
'cuenta
k = k + 1
b(k, 2) = dic.Count
'
With Sheets("Hoja5")
.Cells.ClearContents
.Range("E3").Resize(k, UBound(a, 2)).Value = b
End With
End Sub
Prueba el siguiente ajuste, cambia "Hoja4" y "Hoja5" por el nombre de tus hojas.
En "Hoja5" quedará el resultado.
Sub Macro1()
'Por.Dante Amor
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Variant, b As Variant
Dim i As Long, j As Long, k As Long
Dim ant1 As String, ant2 As String
Dim dic As Object
'
Set s1 = Sheets("Hoja4") 'origen
Set dic = CreateObject("scripting.dictionary")
'
a = s1.Range("E3:K" & s1.Range("E" & Rows.Count).End(3).Row).Value2
ReDim b(1 To UBound(a, 1) * 3, 1 To UBound(a, 2))
ant1 = a(2, 1)
ant2 = a(2, 1) & a(2, 2) & a(2, 3) & a(2, 7)
'encabezado
k = 1
For j = 1 To UBound(a, 2)
b(k, j) = a(1, j)
Next
k = k + 1
'
For i = 2 To UBound(a, 1)
If ant1 <> a(i, 1) Then
'cuenta
k = k + 1
b(k, 2) = dic.Count
dic.RemoveAll
k = k + 2
'encabezado
For j = 1 To UBound(a, 2)
b(k, j) = a(1, j)
Next
End If
'
dic(a(i, 2)) = Empty
If ant2 <> a(i, 1) & a(i, 2) & a(i, 3) & a(i, 7) Then
k = k + 1
End If
For j = 1 To UBound(a, 2)
b(k, j) = a(i, j)
Next
'
ant1 = a(i, 1)
ant2 = a(i, 1) & a(i, 2) & a(i, 3) & a(i, 7)
Next
'cuenta
k = k + 1
b(k, 2) = dic.Count
'
With Sheets("Hoja5") 'Destino
.Cells.Clear
.Range("E3").Resize(k, UBound(a, 2)).Value = b
End With
End Sub
Me da gusto verlo de nuevo mi querido amigo Dante, espero que me ayudes con unas preguntas que tengo pendiente. Mil bendiciones. - Francisco Jaimes