Macro para buscar, copiar y pegar transpuesto
¿Me ayudan por favor? Tengo un libro de Excel donde en la primera hoja tengo varias columnas de datos, la primera es el producto, la segunda es clientes y las siguientes son columnas de rangos de tiempo (últimos 2 años separadas por meses) Lo que necesito hacer es que se separen en varias hojas los clientes por producto. Es decir, si tengo en productos Argon, CO2, oxígeno y de más quiero que se copien los datos de consumos por cliente. Lo interesante es que necesito una macro que busque por producto en la hoja de datos, al encontrar todos los clientes del mismo producto que los copie y los pegue en otra hoja pero transpuestos, luego los consumos que me los copie de la hoja de datos pero los consumos se dividen en dinero y volumen, entonces la columna de dinero en la hoja de datos quiero que se copie transpuesta pero que vaya dejando una celda vacía ya que esa celda vacía es la del volumen. Es decir, que se ponga un valor si y otro no en dinero por mes y que haga lo mismo con el volumen. No sé si me expliqué bien.
Cualquier cosa estoy al pendiente y de
H o l a : Envíame tu archivo y me explicas con ejemplos, imágenes y comentarios, cómo tienes la información y cómo quieres el resultado.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Dalia Carranza” y el título de esta pregunta.
¡Gracias Dante!
Ya te envié el correo.
Saludos,
Dalia Carranza
H o l a : Te anexo las macros
Dim años As New Collection
'
Sub Separar()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.StatusBar = False
'
Set h1 = Sheets("TODO")
Set h3 = Sheets("FORM")
Set años = Nothing
Call Borrarhojas
ant = ""
k = 2
uc = h1.Cells(3, Columns.Count).End(xlToLeft).Column
If UCase(Left(h1.Cells(3, uc), 3)) = "TOT" Then
uc = uc - 1
End If
'
uf = h1.Range("B" & Rows.Count).End(xlUp).Row
For i = 5 To uf
Application.StatusBar = "Procesando registro: " & i & " de: " & uf
If ant <> h1.Cells(i, "B") Then
'totales
If ant <> "" Then
u = h4.Range("A" & Rows.Count).End(xlUp).Row
t = u + 1
uc2 = h4.Cells(1, Columns.Count).End(xlToLeft).Column
For n = 1 To años.Count
num = años(n)
h4.Cells(t, "A") = "TOTAL " & num
With h4.Range(h4.Cells(t, "B"), h4.Cells(t, uc2))
.FormulaR1C1 = "=SUMPRODUCT((YEAR(R3C1:R" & u & "C1)=" & num & ")*(R3C:R" & u & "C))"
.Value = .Value
End With
t = t + 1
Next
End If
'Nueva hoja
k = 2
Sheets.Add After:=Sheets(Sheets.Count)
Set h4 = ActiveSheet
h4.Cells.NumberFormat = "#,##0"
h4.Columns("A").NumberFormat = "mmm-yy"
h4.Name = h1.Cells(i, "B")
h3.Range("A1:A2").Copy h4.Range("A1")
End If
f = 3
h3.Range("B1:C2").Copy h4.Cells(1, k)
h4.Cells(1, k) = h1.Cells(i, "C")
For j = Columns("D").Column To uc Step 2
h4.Cells(f, "A") = h1.Cells(3, j)
año = Year(h1.Cells(3, j))
Call AgregaAño(año)
h4.Cells(f, k) = h1.Cells(i, j)
h4.Cells(f, k + 1) = h1.Cells(i, j + 1)
f = f + 1
Next
'
k = k + 2
ant = h1.Cells(i, "B")
Next
h1.Select
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "Proceso de separación terminado", vbInformation, "SEPARAR"
End Sub
'
Sub AgregaAño(año)
'Ordena números en una colección
For m = 1 To años.Count
If años(m) > año Then
'si el número almacenado es mayor lo almacena antes
años.Add año, Before:=m
Exit Sub
End If
If años(m) = año Then Exit Sub
Next
años.Add año 'si es el mayor de todos lo agrega al final
End Sub
'
Sub Borrarhojas()
'Por.Dante Amor
Application.DisplayAlerts = False
For Each h In Sheets
Select Case UCase(h.Name)
Case "TODO", "TEMP", "FORM"
Case Else
h.Delete
End Select
Next
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
