Te anexo la macro
Sub OrdenDeTrabajo()
'Por.Dante Amor
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
'
Set l1 = ThisWorkbook
Set h11 = l1.Sheets("STOCK")
Set h12 = l1.Sheets("Productos")
Set h13 = l1.Sheets("Orden de Trabajo")
Set l2 = Workbooks.Add
h12.Range("A10:B200").ClearContents
ruta = l1.Path & "\"
nombre = "programa de Carpinteria del " & Format(Date, "dd mmmm")
caras = Array(":", "\", "/", "?", "*", "[", "]")
l2.SaveAs ruta & nombre & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
j = 10
'
For i = 9 To h11.Range("A" & Rows.Count).End(xlUp).Row
If h11.Cells(i, "D") < 0 Then
If h11.Cells(i, "I") = "" Then
cant = h11.Cells(i, "D") * -1
desc = h11.Cells(i, "A")
desc2 = desc
For k = LBound(caras) To UBound(caras)
desc2 = Replace(desc2, caras(k), "")
Next
h12.Cells(j, "A") = cant 'cant
h12.Cells(j, "B") = desc 'desc
l2.Sheets.Add
Set l21 = l2.ActiveSheet
h13.Cells.Copy
l21.[A1].PasteSpecial xlAll
Call EstablecerImpresion
'h13.Copy after:=(l2.Sheets(l2.Sheets.Count))
l21.Name = Left(desc2, 29) 'desc
l21.[B4] = Date 'fecha
l21.[f2] = cant 'cant
l21.[f1] = desc 'desc
j = j + 1
End If
End If
Next
'
'If l2. Sheets. Count > 1 Then l2. Sheets(1).Delete
l2. Sheets(1). Activate
l2.Save 'As ruta & nombre & ".xlsx"
l2.Close
MsgBox "Orden de Trabajo guardada con el nombre : " & nombre, vbInformation, "ORDEN DE TRABAJO"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias