Macro que combine celdas mientras crea libros Excel.
Para Dante:
Dante estoy trabajando en un reporte de piking automático para almacén, hace un tiempo me ayudaste en una macro que te vaya creando libros de acuerdo a una platilla.
El tema de generar libros por clientes si me funciona, pero se me ocurre, no se si es factible que a medida que genere libros también pueda ir combinando celdas, en una pregunta anterior me resolviste ese tema pero todo se ejecuta en el mismo libro, quisiera saber si se puede añadir un código que vaya combinado a medida que va creando libros por cliente.
Las plantillas que me generan son así:
Quisiera saber si con un codigo puede crear libros pero combinando las celdas Entrega y Tiendas, teniendo en cuenta como la vez anterior que una entrega puede tener varias tiendas.
Tendría que quedar como en la foto:
Este es tu macro que estoy adaptando para que me genere libros por cliente, donde anteriormente.
Sub Por_OD()
'Aporte Ronald C
'Como el usuario dinamico este codigo ayuda a capturar al cualquiera que se loggea
Dim struser As String
struser = CreateObject("WScript.Network").UserName
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.ActiveSheet
Set h2 = l1.Sheets("Por OD")
'
If h1.FilterMode Then h1.ShowAllData
u = h1.Range("A" & Rows.Count).End(xlUp).Row
h1.Range("H:H").Copy h1.Range("AF1")
h1.[h1].Copy h1.[AG1]
h1.Range("AF1:AF" & u).RemoveDuplicates Columns:=1, Header:=xlYes
'
For i = 2 To h1.Range("AF" & Rows.Count).End(xlUp).Row
h1.[AG2] = h1.Cells(i, "AF")
h1.Range("D1:H" & u).AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=h1.Range("AG1:AG2"), Unique:=False
u2 = h1.Range("A" & Rows.Count).End(xlUp).Row
h2.Copy
Set l2 = ActiveWorkbook
Set h3 = l2.ActiveSheet
h1.Range("C2:F" & u2).Copy h3.Range("A9")
h1.Range("N2:N" & u2).Copy h3.Range("E9")
h1.Range("M2:M" & u2).Copy h3.Range("F9")
'Actualizado Por. Dante Amor
l2.SaveAs Filename:="C:\Users\" & struser & "\Desktop\SEPARAR PICKING\" & h1.Cells(i, "AF") & ".xls", _
FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
l2.Close
Next
If h1.FilterMode Then h1.ShowAllData
h1.Range("AF:AG").ClearContents
Application.ScreenUpdating = True
Range("A11:K10000"). EntireColumn. AutoFit
Range("A11:K10000"). EntireRow. AutoFit
MsgBox "Terminado"Si deseas que te envíe mi archivo a tu correo me confirmas.
1 respuesta
Estimado Dante, te envié a tu correo la información, si es viable la idea me espero puedas ayudarme. Gracias.
Te anexo la macro
Sub Por_OD()
'Aporte Ronald C.
'Como el usuario dinamico este codigo ayuda a capturar al cualquiera que se loggea
Dim struser As String
struser = CreateObject("WScript.Network").UserName
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.ActiveSheet
Set h2 = l1.Sheets("Por OD")
'
If h1.FilterMode Then h1.ShowAllData
u = h1.Range("A" & Rows.Count).End(xlUp).Row
h1.Range("H:H").Copy h1.Range("AF1")
h1.[h1].Copy h1.[AG1]
h1.Range("AF1:AF" & u).RemoveDuplicates Columns:=1, Header:=xlYes
'
For i = 2 To h1.Range("AF" & Rows.Count).End(xlUp).Row
h1.[AG2] = h1.Cells(i, "AF")
h1.Range("D1:H" & u).AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=h1.Range("AG1:AG2"), Unique:=False
u2 = h1.Range("A" & Rows.Count).End(xlUp).Row
h2.Copy
Set l2 = ActiveWorkbook
Set h3 = l2.ActiveSheet
H1.Range("C2:F" & u2). Copy h3. Range("A9")
H1.Range("N2:N" & u2). Copy h3. Range("E9")
H1.Range("M2:M" & u2). Copy h3. Range("F9")
'
'Combinar
'Act. Por. Dante Amor
For j = 9 To h3.Range("A" & Rows.Count).End(xlUp).Row
contarsi = Application.WorksheetFunction.CountIf(h3.Columns(1), h3.Cells(j, "A"))
If contarsi > 1 Then
With h3.Range(h3.Cells(j, "A"), h3.Cells(j + contarsi - 1, "A"))
.Merge
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
End With
With h3.Range(h3.Cells(j, "F"), h3.Cells(j + contarsi - 1, "F"))
.Merge
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
End With
End If
Next
'l2.SaveAs Filename:="C:\Users\" & struser & "\Desktop\POR OD\" & h1.Cells(i, "AF") & ".xls", _
FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
l2.Close
Next
If h1.FilterMode Then h1.ShowAllData
h1.Range("AF:AG").ClearContents
Application.ScreenUpdating = True
Range("A11:K10000").EntireColumn.AutoFit
Range("A11:K10000").EntireRow.AutoFit
MsgBox "Terminado"
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
