Solicita macro para elaborar proyectos excel vba
H o l a: Dante
Le solicito el archivo para estudiarlo y aplicar a mi proyecto, estaré agradecido
Macro para buscar, copiar y pegar transpuesto
Mi Email: [email protected]
1 respuesta
Respuesta de Dante Amor
1
Te anexo la macro
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
