Soporte con macro que se ajuste al texto y ponga bordes variables.
Su soporte con una macro que me aporto Dante, espero también pueda leer esta pregunta.
- Aparte que me guarde libros con el nombre del cliente sean también con fecha y hora (Con la función ahora) Ejemplo: SAGA FALABELLA, DEBERIA GUARDAR LOS LIBROS SAGA FALABELLA - 25.09.2017 1406
- Que se guarden y genere bordes dinámicos de acuerdo al tamaño del archivo. Asimismo, las columnas se auto ajusten a los datos. Les paso la programación y si me pueden aportar que código se adicionaría.
Adjunto fotos caso 1 y 2 y la programación.
Foto como guarda sin formato
Foto como debe guardarlo, bordes de acuerdo al texto y negrita la columna entrega y tiendas ( con código macro)
adjunto el código
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
3 Respuestas
Respuesta de Programar Excel
1
Mira http://programarexcel.com descarga cientos de ejemplos de macros GRATIS.
https://youtube.com/programarexcel suscribe y recibe en tu mail ejemplos de macros
Respuesta de Jaime Segura
2
Para que se dibujen los cuadros agrega:
Como segunda línea del código
Dim rango As range, i as integer
y casi al final, antes de la linea de Msgbox "Terminado":
Set rango = Range("A8:M" & h3.Range("B" & Rows.Count).End(xlUp).Row)
For i = 7 To 12
With rango.Borders(i)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Next iYo veo que el código que tienes ya tiene el autoajuste en las columnas configuradas
Y para que grabe con la hora modifica la línea que graba
l2.SaveAs Filename:="C:\Users\" & struser & "\Desktop\POR OD\" & h1.Cells(i, "AF") & ".xls", _
por
l2.SaveAs Filename:="C:\Users\" & struser & "\Desktop\POR OD\" & h1.Cells(i, "AF") & Format(Now, "dd.mm.yyyy hhmm") & ".xls", _
Estimado:
Me guarda el archivo con fecha y hora, pero e sale un error 424 y no guarda los libros con borde.
¿Estoy pegando en un lugar que no debo el código?
Pusiste el
Dim rango as range al principio como indique?
Respuesta de Dante Amor
2
Te anexo la macro actualizada
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
u3 = h3.Range("A" & Rows.Count).End(xlUp).Row
For j = 9 To u3
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
.Font.Bold = True
End With
With h3.Range(h3.Cells(j, "F"), h3.Cells(j + contarsi - 1, "F"))
.Merge
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.Font.Bold = True
End With
End If
Next
h3.Range("A9:K" & u3).Borders.LineStyle = xlContinuous
'
nombre = h1.Cells(i, "AF") & Format(Now, "dd-mm-yyyy hhmm") & ".xls"
l2.SaveAs Filename:="C:\Users\" & struser & "\Desktop\POR OD\" & nombre, _
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
.
Avísame cualquier duda
.