Macro para invertir filas y columnas dejo de funcionar
Tengo una columna con fechas y debo colocar en otra planilla un año en cada columna. La macro Funcionaba perfectamente y dejo de funcionar, no graba los datos en la nueva planilla. Esta es la macro
Sub procesar()
Application.ScreenUpdating = False
Application.StatusBar = False
Set l1 = ThisWorkbook
Set h1 = l1.ActiveSheet
libro = h1.[M1]
hoja = h1.[M2]
col = h1.[M3]
'
If libro = "" Then
MsgBox "Captura el libro destino"
Exit Sub
End If
If hoja = "" Then
MsgBox "Captura la hoja destino"
Exit Sub
End If
If col = "" Then
MsgBox "Captura la columna origen"
Exit Sub
End If
existe = False
For Each h In Workbooks
If LCase(h.Name) = LCase(libro) Then
existe = True
Exit For
End If
Next
If existe = False Then
MsgBox "No está abierto el libro: " & libro2
Exit Sub
End If
'
existe = False
Set l2 = Workbooks(libro)
For Each h In l2.Sheets
If LCase(h.Name) = LCase(hoja) Then
existe = True
Exit For
End If
Next
If existe = False Then
MsgBox "La hoja destino no existe en el libro destino"
Exit Sub
End If
Set h2 = l2.Sheets(hoja)
'
u = h1.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To u
Application.StatusBar = "Procesando registro : " & i & " de : " & u
dia = Day(h1.Cells(i, "A"))
Mes = Month(h1.Cells(i, "A"))
año = Year(h1.Cells(i, "A"))
Fecha = DateSerial(2016, Mes, dia)
Set b = h2.Columns("A").Find(Fecha, lookat:=xlWhole)
If Not b Is Nothing Then
fila = b.Row
Set b = h2.Rows(1).Find("a" & año, lookat:=xlWhole)
If Not b Is Nothing Then
cold = b.Column
h2.Cells(fila, cold) = h1.Cells(i, col)
End If
End If
Next
Application.StatusBar = False
MsgBox "Fin"
End Sub
1 Respuesta
Cambia estas líneas
Fecha = DateSerial(2016, Mes, dia)
Set b = h2.Columns("A").Find(Fecha, lookat:=xlWhole)Por estas
Fecha = DateSerial(Año, Mes, dia)
Set b = h2.Columns("A").Find(Fecha, ,xlvalues, xlWhole)Si todavía no funciona, prueba con estas líneas
Fecha = DateSerial(Año, Mes, dia)
Set b = h2.Columns("A").Find(Fecha, , xlformulas, xlWhole)Y si no funciona, envíame tus archivos para revisar los datos.
Mi correo: [email protected]
Le envié por correo los archivos. Muchas gracias
Hice cambios a la macro
Sub procesar()
'Por Dante Amor
Dim l2 As Workbook, wb As Workbook
Dim h As Worksheet, h1 As Worksheet, h2 As Worksheet
Dim libro As String, hoja As String, col As Long, año As String
Dim existe As Boolean, a As Variant, b As Variant
Dim i As Long, cold As Long, fila As Long, lr As Long, lc As Long
Dim dicb As Object, dicc As Object
Set h1 = ThisWorkbook.ActiveSheet
libro = h1.[M1]
hoja = h1.[M2]
col = h1.[M3]
'
If libro = "" Or hoja = "" Or col = Empty Then
MsgBox "Faltan datos"
Exit Sub
End If
existe = False
For Each wb In Workbooks
If LCase(wb.Name) = LCase(libro) Then existe = True
Next
If existe = False Then
MsgBox "No está abierto el libro: " & libro
Exit Sub
End If
existe = False
Set l2 = Workbooks(libro)
For Each h In l2.Sheets
If LCase(h.Name) = LCase(hoja) Then existe = True
Next
If existe = False Then
MsgBox "La hoja destino no existe en el libro destino"
Exit Sub
End If
Set h2 = l2.Sheets(hoja)
'
a = h1.Range("A2:D" & h1.Range("A" & Rows.Count).End(3).Row).Value2
lr = h2.Range("A" & Rows.Count).End(3).Row
lc = h2.Cells(1, Columns.Count).End(1).Column
b = h2.Range("A1", h2.Cells(lr, lc)).Value2
Set dicb = CreateObject("Scripting.Dictionary")
Set dicc = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(b, 1)
dicb(b(i, 1)) = i
Next
For i = 1 To UBound(b, 2)
dicc(b(1, i)) = i
Next
For i = 2 To UBound(a, 1)
If dicb.exists(a(i, 1)) Then
fila = dicb(a(i, 1))
año = "a " & Year(a(i, 1))
If dicc.exists(año) Then
cold = dicc(año)
b(fila, cold) = a(i, col)
End If
End If
Next
h2.Range("A1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
MsgBox "Fin"
End SubAhora es más rápida.
Si, es muchísimo más rápida, pero solo logro grabar el último año.
Así quedaría la macro:
Option Explicit
Sub procesar()
'Por Dante Amor
'DECLARACIÓN DE VARIABLES
Dim l2 As Workbook, h1 As Worksheet, h21 As Worksheet, h22 As Worksheet, h23 As Worksheet
Dim año As Long, dia As Long, i As Long, lr As Long, lc As Long
Dim a As Variant, b1 As Variant, b2 As Variant, b3 As Variant, dicc As Object
'ENTRADA DE DATOS
Set h1 = ThisWorkbook.Sheets("datos diarios")
Set l2 = Workbooks(h1.Range("M1").Value)
Set h21 = l2.Sheets("TX")
Set h22 = l2.Sheets("TI")
Set h23 = l2.Sheets("pp")
Set dicc = CreateObject("Scripting.Dictionary")
a = h1.Range("A2:D" & h1.Range("A" & Rows.Count).End(3).Row).Value2
lr = h21.Range("A" & Rows.Count).End(3).Row
lc = h21.Cells(1, Columns.Count).End(1).Column
b1 = h21.Range("A1", h21.Cells(lr, lc)).Value2
b2 = h22.Range("A1", h22.Cells(lr, lc)).Value2
b3 = h23.Range("A1", h23.Cells(lr, lc)).Value2
For i = 1 To UBound(b1, 2)
dicc(Val(Right(b1(1, i), 4))) = i
Next
'PROCESO
For i = 1 To UBound(a, 1)
año = Year(a(i, 1))
dia = a(i, 1) - DateSerial(año, 1, 1) + 1
If Month(a(i, 1)) > 2 Then If Day(DateSerial(año, 2, 29)) = 1 Then dia = dia + 1
If dicc.exists(año) Then
b1(dia + 1, dicc(año)) = a(i, 2)
b2(dia + 1, dicc(año)) = a(i, 3)
b3(dia + 1, dicc(año)) = a(i, 4)
End If
Next
'SALIDA
H21. Range("A1"). Resize(UBound(b1, 1), UBound(b1, 2)).Value = b1
h22. Range("A1"). Resize(UBound(b2, 1), UBound(b2, 2)).Value = b2
h23. Range("A1"). Resize(UBound(b3, 1), UBound(b3, 2)).Value = b3
MsgBox "Fin"
End SubAhora funciona de la siguiente manera:
1. Debes tener abierto el libro indicado en la celda M1, por ejemplo: "planilla resultado.xlsx"
2. En las celdas B1, C1 y D1 tienes estos datos: TX, TI y pp. De esa manera deberán llamarse las hojas en el libro "planilla resultado.xlsx"
3. En el libro ""planilla resultado.xlsx"" las 3 hojas deben tener la misma estructura, el mismo número de fechas en la columna A y el mismo número de años en la fila 1.
4. En el libro "planilla resultado.xlsx", en la fila 1, no importa si tienes "a 1940" o "a1940", la macro considera los últimos 4 dígitos.
5. La macro hace al mismo tiempo las 3 hojas, entonces solamente debes realizar una ejecución.
6. Ya no es necesario poner la hoja destino, ni la columna origen. La macro toma la columna B y la pone en la hoja "TX", toma la C y la pone en la hoja "TI", y la D en la "pp".
Prueba y me comentas.
