Macro que detecte fila vacías para pegar series
Tengo una plantilla donde genero guías manuales, le he adaptado un código VBA para que me suba series a partir de la celda B25 hacia abajo.
Como se muestra en la foto.
Pero ya detecte que aun la macro no me es eficiente. Debido a que, cuando tengo un solo código en A24 y una descripcón en B25, la macro sube las series correctamente.
Pero tengo varios escenarios :
Es decir, la guía puede tener varios códigos y descripciones, y subo series por descripción y cantidad de 10 en 10, la primera empezó de la B25, pero después la macro tendría que ubicar la siguiente fila vacía que en la foto empieza en B33 y termina B34 y así sucesivamente al cargar. En el ejemplo, lo resaltado en amarillo.
La guía puede tener varios códigos en distintas direcciones de celda, las series siempre se van a cargar en la columna B ; Pero debe ubicar la fila vacía para subirlas.
Adjunto el código VBA para adaptar para ver como se puede adaptar, ya que yo lo puse empiece en B25 y no debe ser así.
Sub Subirseries()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
ruta = l1.Path & "\"
ChDir ruta
archi = Dir(ruta & "*.xlsm*")
Do While archi <> ""
If archi <> l1.Name Then
Set l2 = Workbooks.Open(ruta & archi)
Set h2 = l2.Sheets(1)
u2 = h2.Range("O" & Rows.Count).End(xlUp).Row
If u2 < 1 Then u2 = 1
'h2.Range("F12:F" & u2) = h2.[B8]
u1 = h1.Range("B" & Rows.Count).End(xlUp).Row + 1
If u1 < 25 Then u1 = 25
h2.Range("O1:O" & u2).Copy
h1.Range("B25:B" & u1).PasteSpecial Paste:=xlValues
l2.Save
l2.Close
End If
archi = Dir()
Loop
Range("B25").Select
End SubMis series la jalo de otro libro que empieza de la celda O1
están en este orden
Atento a su soporte.
Te anexo la macro actualizada
Sub Subirseries()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
ruta = l1.Path & "\"
ruta = "c:\trabajo\"
ChDir ruta
archi = Dir(ruta & "*.xlsm*")
u1 = 25
Do While archi <> ""
If archi <> l1.Name Then
Set l2 = Workbooks.Open(ruta & archi)
Set h2 = l2.Sheets(1)
u2 = h2.Range("O" & Rows.Count).End(xlUp).Row
For i = 1 To u2
Do While h1.Cells(u1, "B").Value <> ""
u1 = u1 + 1
Loop
h1.Cells(u1, "B").Value = h2.Cells(i, "O").Value
Next
l2.Close False
End If
archi = Dir()
Loop
Range("B25").Select
End Sub[sal u dos
1 respuesta más de otro experto
Ya la había desarrollado pensando que habías dejado la consulta a mi nombre. Esta es otra opción. Aquí se pasa por bloques de lugares vacíos a diferencia de la de dam que lo hace fila x fila. En esta cantidad de registros no hacen diferencias.
(La macro parece más extensa porque lleva muchas líneas con aclaraciones. Te comento otros detalles luego)
Sub Subirseries()
'Por Juan Arenas
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
ruta = l1.Path & "\"
ChDir ruta
archi = Dir(ruta & "*.xlsm*")
Do While archi <> ""
If archi <> l1.Name Then
Set l2 = Workbooks.Open(ruta & archi)
Set h2 = l2.Sheets(1)
ini2 = 1
u2 = h2.Range("O" & Rows.Count).End(xlUp).Row
u1 = 25
iniciando:
'se busca el inicio de las vacías
While h1.Range("B" & u1) <> ""
u1 = u1 + 1
Wend
x = u1 + 1
'se busca el final de las vacías
While h1.Range("B" & x) = ""
x = x + 1
Wend
y = x - u1 - 1 'cantidad de filas vacías encontradas
h2.Range("O" & ini2 & ":O" & ini2 + y).Copy
h1.Range("B" & u1 & ":B" & u1 + y).PasteSpecial Paste:=xlValues
'si hay más registros para pasar se repiten los bucles anteriores
ini2 = ini2 + y + 1
If ini2 >= u2 Then GoTo saliendo
'la próxima búsqueda se inicia en fila x
u1 = x
GoTo iniciando
saliendo:
l2.Save
l2.Close
End If
archi = Dir()
Loop
Range("B25").Select
End Sub