طلب تعديل في ملف إكسل

[Alaa Ammar New]

السلام عليكم ورحمة الله وبركاته

عندي ملف إكسل عن الأنشطة الخاصة بالمؤسس الي أعمل بها، وقد ساعدني فيها كثيرا الأستاذ الكريم @محمد هشام. جزاه الله عني خير الجزاء

الملف يتم فيه تصدير البيانات الى وورد او pdf او تصدير فترات معينة وبه عامود (J) به روابط لتلك الانشطة وفيه ملفات pdf على شكل ملفات على شكل أيقونات عملتها من خلال ادراج كائن وخصوصا في آخر الجدول لاني ابتديت احطها فعند التصدير الى وورد او pdf يتم تصدير الجدول لكن بدون ملفات الpdf التي على شكل أيقونات فتظهر الروايط التشعبية في الخلايا والخلايا التي بها ملفات pdf تظهر فارغة

فهل ممكن تعديل اكواد التصدير لpdf  ووورد لكي تسمح بتصدير البيان المطلوب بملفات الpdf والروابط كلها؟

وكلذلك ملف الوورد الناتج عن التصدير يظهر غير منسق وخارج من الصفحة فهل يمكن تصويب ذلك من خلال كود التصدير؟

وجزاكم الله كل خير يا رب العالمين

رابط الملف لكبر حجمه

https://drive.google.com/file/d/1lftlr4JfF4DZcV_H2e0HfEaK2jleZZIu/view?usp=sharing

[Alaa Ammar New]

اذا كان متعذر تنزيل الملف من حضراتكم لتعديله فيمكن بعد اذنكم عمل التعديل في كود التصدير الى وورد واعادة رفعه لكي استبدله؟ @محمد هشام. او اي من الخبراء الكبار اخواتي من المنتدى

الكود:

Public Property Get n() As Worksheet: Set n = Worksheets("WordCopy")
End Property
Sub Copy_Transfer_WORD()
Dim Q As Integer
Q = 0
    Dim WS As Worksheet
    Dim Rng As Range, j As Range, Irow As Range
    Dim x As Long, r As Long, lastRow As Long
    Dim i As Integer, Ary As Variant
    Dim Cnt()  As String
    Dim arr() As String
    Dim tmp As Range
    Set WS = Sheets("الانشطة")
    lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    msg = MsgBox("؟" & " " & "Word " & ":" & " تصدير التقرير بصيغة", vbYesNo, WS.Name)
    If msg <> vbYes Then Exit Sub

    n.Visible = xlSheetVisible: n.Cells.UnMerge
    Set tmp = n.Range("A1:l" & n.Rows.Count)
    Cnt() = Split("A-A,D-C,E-D,F-E,G-F,H-G,I-H,J-I", ","): tmp.Clear
    For i = 0 To UBound(Cnt)
          arr = Split(Cnt(i), "-")
    Set Rng = n.Range(arr(1) & n.Rows.Count).End(xlUp)
    WS.Range(arr(0) & "5:" & arr(0) & lastRow).Copy Destination:=Rng
Next i
rngA = Split("C", ","): rngB = Split("B", ",")
For i = LBound(rngA) To UBound(rngA)
WS.Range(rngA(i) & "5:" & rngA(i) & lastRow).Copy
With n.Range(rngB(i) & "1")
    .PasteSpecial Paste:=xlPasteValues
     Application.CutCopyMode = False
End With
Next i

'n.Columns("A").SpecialCells(xlBlanks).EntireRow.Delete
Lr = n.Cells(n.Rows.Count, "A").End(xlUp).Row
Set a = n.Rows(1): Set b = n.Rows(2): Set d = n.[A1:I1]: Set E = n.Range("A3:I" & Lr)
    a.Font.Size = 14: a.RowHeight = 75: a.Font.Bold = True: b.RowHeight = 40: b.Font.Bold = True: b.Font.Size = 12
    d.Merge: d.Interior.Color = RGB(192, 192, 192)
    n.[A2:I2].Interior.Color = RGB(215, 238, 247): n.[H2:I2].Merge
    E.Interior.ColorIndex = xlNone: E.Font.Name = "AdvertisingBold": E.Font.Size = 13
F = n.Cells(2, n.Columns.Count).End(xlToLeft).Column + 1
    n.Range(n.Cells(2, 1), n.Cells(Lr, F)).Borders.Weight = xlThin
    
    Ary = Array(5, 15, 38, 38, 38, 15, 15, 15, 15)
        For x = 0 To UBound(Ary)
        n.Columns(x + 1).ColumnWidth = Ary(x)
 Next x
Set Irow = n.Range("A3", n.Cells(n.Rows.Count, "A").End(xlUp))
For Each j In Irow.Rows
        If j.RowHeight < 20 Then: j.RowHeight = 30: Else j.EntireRow.AutoFit
  Next
  n.Range("b3:b" & n.Rows.Count).NumberFormat = "yyyy/mm/dd"
  n.Range("A:I").EntireColumn.HorizontalAlignment = xlCenter
  n.Range("A:I").EntireColumn.VerticalAlignment = xlCenter
With n.Range("A3:A" & n.Cells(Rows.Count, "B").End(xlUp).Row)
    .Value = Evaluate("ROW(" & .Address & ")-2")
End With
 WS.Activate: ExcelToWordSheet1
 n.Visible = xlSheetVeryHidden
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 End Sub
Sub Copy_Transfer_WORD1()
    
    Dim WS As Worksheet
    Dim Rng As Range, j As Range, Irow As Range
    Dim x As Long, r As Long, lastRow As Long
    Dim i As Integer, Ary As Variant
    Dim Cnt()  As String
    Dim arr() As String
    Dim tmp As Range
    Set WS = Sheets("Sheet1")
    lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    msg = MsgBox("؟" & " " & "Word " & ":" & " تصدير التقرير بصيغة", vbYesNo, WS.Name)
    If msg <> vbYes Then Exit Sub

    n.Visible = xlSheetVisible: n.Cells.UnMerge
    Set tmp = n.Range("A1:l" & n.Rows.Count)
    Cnt() = Split("A-A,D-C,E-D,F-E,G-F,H-G,I-H,J-I", ","): tmp.Clear
    For i = 0 To UBound(Cnt)
          arr = Split(Cnt(i), "-")
    Set Rng = n.Range(arr(1) & n.Rows.Count).End(xlUp)
    WS.Range(arr(0) & "7:" & arr(0) & lastRow).Copy Destination:=Rng
Next i
rngA = Split("C", ","): rngB = Split("B", ",")
For i = LBound(rngA) To UBound(rngA)
WS.Range(rngA(i) & "7:" & rngA(i) & lastRow).Copy
With n.Range(rngB(i) & "1")
    .PasteSpecial Paste:=xlPasteValues
     Application.CutCopyMode = False
End With
Next i

'n.Columns("A").SpecialCells(xlBlanks).EntireRow.Delete
Lr = n.Cells(n.Rows.Count, "A").End(xlUp).Row
Set a = n.Rows(1): Set b = n.Rows(2): Set d = n.[A1:I1]: Set E = n.Range("A3:I" & Lr)
    a.RowHeight = 75: b.RowHeight = 40: b.Font.Bold = True: b.Font.Size = 14
    d.Merge: d.Interior.Color = RGB(192, 192, 192)
    n.[A2:I2].Interior.Color = RGB(215, 238, 247): n.[H2:I2].Merge
    E.Interior.ColorIndex = xlNone: E.Font.Name = "AdvertisingBold": E.Font.Size = 13
F = n.Cells(2, n.Columns.Count).End(xlToLeft).Column + 1
    n.Range(n.Cells(2, 1), n.Cells(Lr, F)).Borders.Weight = xlThin
 
    Ary = Array(5, 15, 38, 38, 38, 15, 15, 15, 15)
        For x = 0 To UBound(Ary)
        n.Columns(x + 1).ColumnWidth = Ary(x)
 Next x
 
Set Irow = n.Range("A3", n.Cells(n.Rows.Count, "A").End(xlUp))
For Each j In Irow.Rows
        If j.RowHeight < 20 Then: j.RowHeight = 30: Else j.EntireRow.AutoFit
  Next
 '-------------------
  n.Range("b3:b" & n.Rows.Count).NumberFormat = "yyyy/mm/dd"
  n.Range("A:I").EntireColumn.HorizontalAlignment = xlCenter
  n.Range("A:I").EntireColumn.VerticalAlignment = xlCenter
With n.Range("A3:A" & n.Cells(Rows.Count, "B").End(xlUp).Row)
    .Value = Evaluate("ROW(" & .Address & ")-2")
End With
 WS.Activate: ExcelToWordSheet1
 n.Visible = xlSheetVeryHidden
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 End Sub

Sub ExcelToWordSheet1()
Dim timeV As String
Dim Lr As Long
Dim WS As Worksheet: Set WS = Sheets("WordCopy")
Set v = ActiveSheet
On Error Resume Next
Dim docDest As Word.Document
Dim src As Word.Application
Set src = CreateObject("word.application")
src.Visible = True

xname = "Word ملفات"
XPath = ThisWorkbook.path & "\" & xname
'  Application.ScreenUpdating = False
 Lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
 WS.Range("A1: i" & Lr).Copy
      
Set docDest = src.Documents.Add
src.Selection.PasteExcelTable _
    LinkedToExcel:=False, WordFormatting:=False, RTF:=False
    Application.CutCopyMode = False
src.ActiveDocument. _
   PageSetup.Orientation = wdOrientLandscape
src.ActiveDocument. _
   PageSetup.PaperSize = WdPaperSize.wdPaperA3
    If Dir(XPath, vbDirectory) = "" Then MkDir XPath
   timeV = "(" & Format(Day(Date), "00") & "_" & Format(Month(Date), "00") & "_" & Year(Date) & "  " & Format(Hour(Time()), "00") & Format(Minute(Time()), "00") & ")"

          docDest.SaveAs XPath & "\" & timeV & v.Name & ".docx"
              docDest.Close
            Set docDest = Nothing
       src.Quit
    Set src = Nothing
    ' Application.ScreenUpdating = True
    MsgBox "Done", vbInformation
Set WordApp = CreateObject("Word.Application")
WordApp.Documents.Open (XPath & "\" & timeV & v.Name & ".docx")
WordApp.Visible = True
WordApp.Activate
End Sub
Sub ExcelToWordSheet2()
Dim Lr As Long
Dim WS As Worksheet:  Set WS = Sheets("WordCopy")
Set v = ActiveSheet

On Error Resume Next
Dim docDest As Word.Document
Dim src As Word.Application
Set src = CreateObject("word.application")
src.Visible = True

xname = "Word ملفات"
XPath = ThisWorkbook.path & "\" & xname
' Application.ScreenUpdating = False
 
 Lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
 WS.Range("A1: H" & Lr).Copy
      
Set docDest = src.Documents.Add
src.Selection.PasteExcelTable _
    LinkedToExcel:=False, WordFormatting:=False, RTF:=False
    Application.CutCopyMode = False
src.ActiveDocument. _
   PageSetup.Orientation = wdOrientLandscape
src.ActiveDocument. _
   PageSetup.PaperSize = WdPaperSize.wdPaperA3
    If Dir(XPath, vbDirectory) = "" Then MkDir XPath
          docDest.SaveAs XPath & "\" & v.Name & ".docx"
              docDest.Close
            Set docDest = Nothing
       src.Quit
    Set src = Nothing
   ' Application.ScreenUpdating = True
    MsgBox "Done", vbInformation
End Sub

 

 

تم تعديل منذ 4 دقائق بواسطه Alaa Ammar New