قبل أن أرى ردك كنت أعمل على الملف الأصلي .. لذا جرب الكود التالي على الملف الأصلي
Sub Test()
Dim wb As Workbook
Dim ws As Worksheet
Dim sh As Worksheet
Dim wk As Worksheet
Dim shp As Shape
Dim rg As Range
Dim cl As Range
Dim s As String
Dim r As Long
Dim m As Long
Dim i As Long
Const x As Long = 35
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets("AllToOnePDF")
Set rg = ws.Range("K5:K" & ws.Cells(Rows.Count, "K").End(xlUp).Row)
Set wb = Workbooks.Add
Set sh = wb.Worksheets(1)
r = 1
For Each cl In rg
If cl.Value = "" Then GoTo Skipper
ws.Range("E1").Value = cl.Value
ws.Copy After:=sh
Application.EnableEvents = False
Set wk = ActiveSheet
With wk
.Cells.Copy
.Cells.PasteSpecial Paste:=xlPasteValues
.Columns("I:L").Delete: .Columns("A:B").Delete
.Rows("1:3").Delete
For Each shp In .Shapes
shp.Delete
Next shp
If .Range("D5") <> "" Then
.Range("A1:F35").EntireRow.Copy
sh.Range("A" & r).Resize(35, 6).EntireRow.PasteSpecial xlPasteFormats
sh.Range("A" & r).Resize(35, 6).EntireRow.PasteSpecial xlPasteColumnWidths
sh.Range("A" & r).Resize(35, 6).EntireRow.PasteSpecial xlPasteAll
r = r + 35
End If
If .Range("D40") <> "" Then
.Range("A36:F70").EntireRow.Copy
sh.Range("A" & r).Resize(35, 6).EntireRow.PasteSpecial xlPasteFormats
sh.Range("A" & r).Resize(35, 6).EntireRow.PasteSpecial xlPasteColumnWidths
sh.Range("A" & r).Resize(35, 6).EntireRow.PasteSpecial xlPasteAll
r = r + 35
End If
Application.CutCopyMode = False
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Application.EnableEvents = True
Skipper:
Next cl
With sh
ActiveWindow.View = xlPageBreakPreview
.ResetAllPageBreaks
With .PageSetup
.TopMargin = Application.InchesToPoints(0.35)
.BottomMargin = Application.InchesToPoints(0.35)
End With
.DisplayPageBreaks = False
.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
m = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
For i = x + 1 To m Step x
.HPageBreaks.Add Before:=.Cells(i, 1)
Next i
ActiveWindow.View = xlNormalView
s = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))
.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\Users\" & Environ("UserName") & "\Desktop\" & s, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
wb.Close False
End With
Application.ScreenUpdating = True
MsgBox "Done...", 64
End Sub
تحميل محتوى الموضوع
عرض نسخة صالحة للطباعة
أرسل هذا الموضوع إلى صديق
