تجميع فواتير اسبوعيه فى ملف pdf واحد

**عادل ابوزيد** · April 18

الاستاذ الفاضل محمد هشام

اشكرك حضرتك على الاهتمام وسرعة الرد على الموضوع واسمح لى لتجميل العمل ان تنظر الى هذه الكلمات :
1 -ان يكون ملف الPDFكل صفحة فيه تظهر الفاتورة كاملاً من المدى ( bw330:ck372)
2 - الملف الاصلى يتعامل مع اسابيع بمعنى يتم انشاء شيت لكل اسبوع وبالتالى هناك فواتير خاصة بكل اسبوع لذا تم استحداث شيت باسم فواتير الاسبوع برجاء استكمال الكود لترحيل الفواتير بجوار بعضها كما هو موضح بالشيت
3 - تم تفسير بعض اجزاء الكود برجاء استكمال باقى الاجزاء

استاذى الفاضل سلمت يداك ولكن احب اوضح

1 - الكود الاول لعمل ملف الـ PDF شكل الفواتير بالملف غير مجمع بمعنى ان الفاتورة بتكون ناقصة بتظهر نصفها والنصف الاخر فى وسط الملف .. حاولت اغير من اعدادات الورقة المسماه بـ PDF ولم تفلح التجربة .. برجاء الاطلاع عليها

2 - كود الترحيل الذى تفضلتم بعمله رائع ولكن ما اريده ان هذا الكود سيتم استخدامه اكثر من مرة بعدد اسابيع العام والمراد اظهار هذه الفواتير فى شيت واحد وضعت تصورى فى شيت باسم الشكل المطلوب ( ممكن حضرتك تضع تصور اخر يلبى ما ابغيه ، ما فيش مشكلة المهم ان فواتير السنة كلها تظهر فى شيت واحد ) هذا بخلاف شيت الPDF الخاص بالطباعة

3 - برجاء استكمال شرح كود الPDF

Book222بالتعديل.xls

**محمد هشام.** · April 26

في 24‏/4‏/2024 at 09:18, عادل ابوزيد said:

لكود الاول لعمل ملف الـ PDF شكل الفواتير بالملف غير مجمع بمعنى ان الفاتورة بتكون ناقصة بتظهر نصفها والنصف الاخر فى وسط الملف

تقصد ان هدا الشكل لا يناسبك

في 24‏/4‏/2024 at 09:18, عادل ابوزيد said:

2 - كود الترحيل الذى تفضلتم بعمله رائع ولكن ما اريده ان هذا الكود سيتم استخدامه اكثر من مرة بعدد اسابيع العام والمراد اظهار هذه الفواتير فى شيت واحد وضعت تصورى فى شيت باسم الشكل المطلوب ( ممكن حضرتك تضع تصور اخر يلبى ما ابغيه ، ما فيش مشكلة المهم ان فواتير السنة كلها تظهر فى شيت واحد ) هذا بخلاف شيت الPDF الخاص بالطباعة

هل قمت بتجربة هدا

Sub test()
Dim lCol As Long, MyRng As Range
Set desWS = ActiveSheet: Set ws = Sheet2
If Len(desWS.[CA328].Value) = 0 Then Exit Sub

ws.Cells.Clear
For i = desWS.[CA328] To desWS.[CE328]: desWS.[BU331].Value = i
Set MyRng = desWS.[BW330:CK372]
Application.ScreenUpdating = False

MyRng.Copy

    If ws.[D9] = "" Then
        MyRng.Copy
        With ws.[c5]
            .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats
        End With
    Else
        lCol = ws.Cells(9, ws.Columns.Count).End(xlToLeft).Column + 5
        MyRng.Copy
        With ws.Cells(5, lCol)
        .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats
        End With
    End If
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
Next i
End Sub

2024-04-11 الفواتير من 2024-04-05 الى.pdf

**عادل ابوزيد** · April 26

السلام عليكم .. استاذى الفاضل الكود السابق يقوم بمسح الورقة قبل الترحيل وبالتالى ما سيتم اظهاره هو الترحيل الخاص بالاسبوع الحالى فقط اما الترحيلات السابقة فلن تظهر

والمطلوب ان كل اسبوع يتم ترحيله لا يتم مسح الترحيلات السابقة واظهار النتائج ( هناك شكلين كما ييسر ) كما بالملف التالى

Book222بالتعديل.xls

**محمد هشام.** · April 30

اسف اخي على التاخير في الرد بسبب ظروف العمل وضيق الوقت لدي

تفضل جرب هدا حاولت تعديل الاكواد قدر المستطاع للحصول على نفس الشكل المطلوب اتمنى ان يلبي طلبك

Book معدل.xls

تم تعديل April 30 بواسطه محمد هشام.

**عادل ابوزيد** · April 30

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

استاذى الفاضل .. مش عارف اقول ايه تعجز الكلمات عن التعبير ما بداخلى من شكر وامتنان لشخصكم الكريم .. مجهود تعجز الكلمات امامه .. نتائج مبهرة .. لو استطعت لارسلت اليك باقات ورد بعدد حبات الرمال

واسمح لى برجائين الاول .. وضع شرط لعدم التكرار الترحيل بحيث ان الاسبوع يرجل مرة واحدة فقط ولا يقبل ان يرحل نفس الاسبوع مرة اخرى

الثانى : تعطيل عمل تحويل الفواتير لملف PDF فى كود الترحيل

تقبل شكرى وامتنانى مع ارسال تحية واعتزاز لشخصكم الكريم

**محمد هشام.** · April 30

راودتني هده الفكرة من قبل لا كن للاسف يصعب عليا فهم طريقة اشتغالك على الملف

السؤال هو في حالة قمت بترحيل فواتير اسبوع معين هل يتم استخراج رقم الاسبوع من اخر تاريخ للفاتورة او فقط تسلسل بعدد الاسابيع المرحلة

مثال لنفترض انه تم ترحيل مثلا اول فاتورة من تاريخ 2024/04/05 الى 2024/04/11

ماهو رقم الاسبوع المتوقع هل 1 او 15

**عادل ابوزيد** · مايو 1

فكرة اشتغالى على الملف اننى اعمل اسبوعى كل اسبوع له مصاريفه وله فواتيره وله مدفوعته وفى نهاية الفترة ( عدد غير معروف من الاسابيع ) يتم تجميع هذه الفواتير والمصاريف والمدفوعات لذلك اذا بحث فى الورقة الخاصة باخر اسبوع مسجل ( من الى ) ستجد اننى باجمع كل التعاملات فى اعمدة معينة بحيث اذا اراد صاحب العمل انهاء العمل على نهاية الاسبوع كذا يكون كل العمل تم تجميعه فى هذا الشيت الخاص بهذا الاسبوع اما شيت الفواتير فخاص بالموردين للرجوع اليه فى اي وقت بمعنى اننى اعمل على اساس التاريخ ( بداية الاسبوع من إلى )وهو دائما يكون من الجمعه الموافق .. إلى الخميس الموافق ....

لذا يفضل فصل كود الترحيل عن تحويل الفواتير PDF

تمتم فى رعاية الله

**محمد هشام.** · مايو 2

ادن اخي حاول التركيز معي سنشتغل على شيت الفواتير لترحيل البيانات اليه مع مراعات عدم تكرار الفواتير في حالة وجودها مسبقا

اعتمادا على رقم الاسبوع الدي سيتم اظافته تلقائيا استنادا الى اخر تاريخ للفواتير المرحلة ويوم بداية الاسبوع الافتراضي بالنسبة لك هو يوم (الجمعة) مع اخد في عين الاعتبار تنسيق وشكل البيانات بعد كل ترحيل المطلوب مسبقا

الاكواد طويلة نوعا ما بسبب التنسيقات المطلوبة لاكنها سريعة في التنفيد 😉

كود الترحيل

Sub Copy_data()               
Dim StDate$, EnDate$, iCnt&, fRow&, Invoice$
Dim rngMain As Range, rngCount, LR&, x&
Dim arrMain As Variant, arrCount() As Variant, sht As Worksheet
Dim Cpt As Range:   Dim FndRng As Range:   Dim MyRng As Range:   Dim c As Range
Dim week As Date:   Dim i As Integer:      Dim Clé As Range:     Dim xDate As Range
Dim d As Integer:   Dim FindWeek As Range: Dim OneRng As Range:  Dim n As Range

Dim desWS As Worksheet:  Set desWS = ActiveSheet
Dim srcWS As Worksheet:  Set srcWS = Sheets("فواتير الاسبوع")
Dim WS As Worksheet:     Set WS = sheet1

Set Clé = desWS.[BU331]: Set MyRng = desWS.[BW330:CK372]
StDate = desWS.[CA328]:  EnDate = desWS.[CE328]

week = desWS.[DC330].Value
    d = 15  ' اليوم الافتراضي لبداية الأسبوع (الجمعة)
st = Application.WeekNum(week, d)
 
 On Error Resume Next
Application.ScreenUpdating = False
 If Len(desWS.[CA328].Value) = 0 Then Exit Sub
 Set FindWeek = srcWS.Rows(3).Find(what:=st, LookIn:=xlValues, _
                                           LookAt:=xlWhole)
If Not FindWeek Is Nothing Then
   If MsgBox("     تم ترحيل فواتير الأسبوع" & " " & st & " :" & "مسبقا" & Chr(10) & Chr(10) _
 & "                معاينة الفاتورة" & "؟", vbYesNo, "تم إلغاء الإجراء") = vbYes Then

Dim cel As Range
Invoice = st.Value
    For Each c In srcWS.Rows(3)
        If c.Value = Invoice Then Set cel = srcWS.Range(FindWeek.Address)
        Application.GoTo Reference:=cel
        ActiveWindow.ScrollColumn = cel.Column - 13: ActiveWindow.ScrollRow = cel.Row - 2
        Exit Sub
      Next
   End If
 Exit Sub
 Else
With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
 WS.Cells.Clear
For i = StDate To EnDate: Clé.Value = i
MyRng.Copy
If WorksheetFunction.CountA(WS.Cells) = 0 Then
LR = WS.Cells(Rows.Count, "j").End(xlUp).Row + 1
Else
LR = WS.Cells(Rows.Count, "j").End(xlUp).Row + 3
End If
  With WS.Range("A" & LR)
    .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats
     Application.CutCopyMode = False
    End With
  
 Next i
fRow = WS.Range("A:O").Find("*", SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious).Row
WS.ResetAllPageBreaks: WS.PageSetup.Zoom = False
WS.PageSetup.PrintArea = "A:O": WS.PageSetup.Orientation = xlLandscape
For i = 1 To fRow Step 45
    j = j + 1
    WS.HPageBreaks.Add WS.Range("A" & i)
Next i
WS.PageSetup.FitToPagesWide = 1: WS.PageSetup.FitToPagesTall = j
Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
 WS.Range("A1:O" & fRow + 1).Copy
   With sht.Range("b" & Rows.Count).End(xlUp)(2)
   .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths
     Application.CutCopyMode = False
 End With
 
 Irow = sht.Range("A:P").Find("*", SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious).Row + 1
 Set rngMain = sht.Range("A2:P" & Irow)
    Set rngCount = sht.[A3]: arrMain = rngMain.Value
    ReDim arrCount(1 To UBound(arrMain, 1), 1 To 1)
    For x = 1 To UBound(arrMain)
        If arrMain(x, 3) = "حامض" Then
            iCnt = iCnt + 1
            arrCount(x - 5, 1) = iCnt
        End If
    Next x
With rngCount.Resize(UBound(arrMain), 1)
    .Value = arrCount: .Font.Color = RGB(255, 0, 0): .Font.Bold = True: .Font.Size = 20
   End With
 If WorksheetFunction.CountA(srcWS.Cells) = 0 Then
  Set OneRng = srcWS.Rows("1:4")
   For Each c In OneRng
    c.HorizontalAlignment = xlGeneral: c.VerticalAlignment = xlCenter: c.HorizontalAlignment = xlCenter
    c.RowHeight = 22: c.Font.Bold = True:: c.Font.Size = 14
    Next c
    
    lCol = srcWS.Cells(10, srcWS.Columns.Count).End(xlToLeft).Column ' + 1
 Else
    lCol = srcWS.Cells(10, srcWS.Columns.Count).End(xlToLeft).Column + 3
 End If
    Dim Col_Widths As Range
    Set Col_Widths = Union(srcWS.Cells(lCol + 3), srcWS.Cells(lCol + 5), srcWS.Cells(5, lCol + 9))
    Set Col_Border = Union(srcWS.Cells(lCol + 3), srcWS.Cells(lCol + 5), srcWS.Cells(5, lCol + 9), srcWS.Cells(1, lCol + 4))
    rngMain.Copy
        With srcWS.Cells(5, lCol)
        .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths
         Application.CutCopyMode = False
         Col_Widths.ColumnWidth = 18
        
        j = Array(StDate, "", "", "", EnDate)
 With srcWS.Cells(1, lCol + 4).Offset(1).Resize(, 5)
    .Value = j: .Interior.Color = vbYellow: .Font.Color = RGB(255, 0, 0)
    .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0)

 With srcWS.Cells(3, lCol + 12)
 .Value = "الأسبوع رقم :": .Font.Color = RGB(255, 0, 0): .Interior.Color = vbYellow
 .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0)

With srcWS.Cells(3, lCol + 13)
.Value = st: .Font.Color = RGB(255, 0, 0): .Interior.Color = vbYellow
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0)
       End With
     End With
  End With
End With
srcWS.Activate: ActiveWindow.ScrollRow = 1: ActiveWindow.ScrollColumn = 1: [B6].Select: ActiveWindow.Zoom = 95
  a = Array("فواتير الأسبوع من", "  ", CDate(desWS.[CV330]), " ", "إلى", "  ", CDate(desWS.[DC330]))
    With srcWS.Cells(2, lCol + 3).Offset(1).Resize(, 7)
    .Value = a: .Interior.Color = RGB(255, 255, 0)
    .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0)
    End With
For Each xDate In srcWS.Range("D3", srcWS.Cells(3, Columns.Count).End(xlToLeft))
      If IsDate(xDate.Value) Then xDate.NumberFormat = "yyyy-mm-dd"
   Next xDate
 sht.Delete
MsgBox " تم ترحيل فواتير الأسبوع رقم :" & " " & st & " " & "بنجاح", vbInformation, "معلومات"
  desWS.Activate
 On Error GoTo 0
  .DisplayAlerts = True
   .ScreenUpdating = True
    End With
  End If
End Sub

اما بالنسبة لكود حفظ الفواتير بصيغة PDF تم فصله وتعديله لتتمكن من حفظ او طباعة اي فواتير مرحلة مسبقا بعد استدعائها بشرط رقم الاسبوع بالشكل المطلوب مسبقا

(كل فاتورة في ورقة مستقلة)

Sub Choose_invoice_Print() 
Dim rng As Range, c As Range, Invoice As Range
Dim Cpt&, Path As String, sFile As String

Dim desWS As Worksheet:  Set desWS = ActiveSheet
Dim srcWS As Worksheet:  Set srcWS = Sheets("فواتير الاسبوع"): Set WS = sheet1
 
 On Error Resume Next
 If WorksheetFunction.CountA(srcWS.Cells) = 0 Then: MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء": Exit Sub
 
Choose_invoice = InputBox(" المرجوا ادخال رقم الأسبوع " & "؟", " : حفظ وطباعة الفواتير الأسبوعية")
If Choose_invoice = "" Then: Exit Sub

FolderName = "Raed": Path = ThisWorkbook.Path & "\" & FolderName

Set FindWeek = srcWS.Rows(3).Find(what:=Choose_invoice, LookIn:=xlValues, _
                                            LookAt:=xlWhole)
If Not FindWeek Is Nothing Then
sFile = "الفواتير من" & " " & Format(FindWeek.Offset(0, -8).Text, "dd-mm-yyyy") _
            & " " & "إلى" & " " & Format(FindWeek.Offset(0, -4).Text, "dd-mm-yyyy")
          
Msg = MsgBox("؟" & " " & "PDF " & ":" & " حفظ فواتير الأسبوع" & " / " & FindWeek & " بصيغة", vbYesNo, sFile)
      If Msg <> vbYes Then Exit Sub
      
Invoice = Choose_invoice.Value
Application.ScreenUpdating = False
    For Each c In srcWS.Rows(3)
        If c.Value = Invoice Then Application.GoTo Reference:=srcWS.Range(FindWeek.Address)
         
    WS.Visible = xlSheetVisible: WS.Cells.Clear
    Cpt = ActiveCell.Column - 3
    Irow = srcWS.Cells(srcWS.Rows.Count, Cpt).End(xlUp).Row
       Set rng = Range(ActiveCell.Offset(3, -12), ActiveCell.Offset(Irow - 2, 2))
        rng.Copy
    With WS.Range("A" & Rows.Count).End(xlUp)(2)
   .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths
     Application.CutCopyMode = False
 End With
Next
f = WS.Range("A:O").Find("*", SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious).Row
WS.ResetAllPageBreaks: WS.PageSetup.Zoom = False
WS.PageSetup.PrintArea = "A:O": WS.PageSetup.Orientation = xlLandscape
For i = 1 To f Step 45
    j = j + 1
    WS.HPageBreaks.Add WS.Range("A" & i)
Next i
WS.PageSetup.FitToPagesWide = 1: WS.PageSetup.FitToPagesTall = j
If Dir(Path, vbDirectory) = "" Then MkDir Path
nf = Dir(Path & "\" & sFile & "*")
  n = 0
  Do While nf <> ""
    n = n + 1
    nf = Dir
  Loop
WS.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=Path & "\" & sFile & " (" & n + 1 & ")" & ".pdf", _
         Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
' تفعيل الطباعة
'WS.PrintOut
 WS.Visible = xlSheetVeryHidden
    Application.ScreenUpdating = True
   Else
   MsgBox "رقم الأسبوع غير موجود على قاعدة البيانات", vbExclamation, "تم إلغاء الإجراء"
   End If
On Error GoTo 0
desWS.Activate
End Sub

Book معدل 2.xls

تم تعديل مايو 2 بواسطه محمد هشام.

**عادل ابوزيد** · مايو 2

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

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

وقبل ان اضع افضل اجابة والموضوع يتم غلقه .. توضيح وليس إلا

رقم الاسبوع تحديده هو السنة المالية من 1/1 يعنى رقم 15 مثلا هو رقم الاسبوع فى السنة

كيف يكون تنسيق الاسبوع فى ورقة الترحيل يوم / شهر / سنة

تقبل الله منا ومنكم صالح الاعمال وجعله فى ميزان حسناتكم

تم تعديل مايو 2 بواسطه عادل ابوزيد

**محمد هشام.** · مايو 2

3 ساعات مضت, عادل ابوزيد said:

رقم الاسبوع تحديده هو السنة المالية من 1/1 يعنى رقم 15 مثلا هو رقم الاسبوع فى السنة

كيف يكون تنسيق الاسبوع فى ورقة الترحيل يوم / شهر / سنة

للاسف غير مفهوم بالنسبة لي مادا تقصد بتنسيق الاسبوع يوم/شهر/سنة

اما ادا كنت تقصد التواريخ عدل هدا الجزء من الكود

 a = Array("فواتير الأسبوع من", " ", CDate(desWS.[CV330]), " ", "إلى", " ", CDate(desWS.[DC330]))
  Set xDate = srcWS.Cells(2, lCol + 3).Offset(1).Resize(, 7)
    With xDate
    .Value = a: .Interior.Color = RGB(255, 255, 0)
    .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0)
    If Not IsDate(xDate.Value) Then xDate.NumberFormat = "yyyy/mm/dd" ' قم بتعديل تنسيق التاريخ بما يناسبك
    End With

Book معدل 3.xls

**عادل ابوزيد** · مايو 3

فتح الله عليك وزادك من نعمه وفضله

باقى استفسار رقم الاسبوع .. بمعنى يوجد سنة فى عملى مثلاً السنة تبدا من من يوم الجمعه الموافق 10 يناير سنة 2025 مثلاً الاسبوع ده رقم يكون كام .. او السؤال بطريقة اخرى يوجد اسبوع من الجمعه إلى الخميس تاريخ بين عامين ميلاديين سنة مثلا 2025 وسنة 2026 فيكون من 28/ 12 / 2025 حتى 3 / 1 / 2026 رقمه كام .... والاسبوع الذى يليه رقمه كام للى هو من 4 / 1 /2026 حتى 10 / 1 / 2026

تقبل شكرى واعتزازى وتقديرى لشخصكم الكريم

بقراءتى للكود جيداً فهمت ان تحديد رقم الاسبوع من يوم الجمعه الذى ينهى الاسبوع ويتم ايجاده بالسطر التالى

week = desWS.[DC330].Value
d = 15
st = Application.WeekNum(week, d)

ولكن لا افهم ليه d = 15

تم تعديل مايو 3 بواسطه عادل ابوزيد

**محمد هشام.** · مايو 4

17 ساعات مضت, عادل ابوزيد said:

ولكن لا افهم ليه d = 15

رقم 15 هو يوم بداية الاسبوع كما جاء في طلبك

في 1‏/5‏/2024 at 16:15, عادل ابوزيد said:

هو دائما يكون من الجمعه الموافق .. إلى الخميس الموافق ....

اليك المرفق التالي ربما تتضح اليك الفكرة لتساعدك على تحديد الرقم المناسب لك

او قم بكتابة تاريخ من اختيارك في الخلية A2 مثلا وجرب استخدام شيئ كهدا

Sub TEST()
Dim d As Integer
d = InputBox("المرجوا ادخال رقم بداية الاسبوع ")
Range("C2").Formula = "=weeknum(a2," & d & ")"
End Sub
'*******************************
Sub TEST2()
Dim week As Date
'خلية التاريخ
week = Range("a2")
'هنا تم تحديد يوم الجمعة كاول يوم في الاسبوع

d = 15

st = Application.WeekNum(week, d)

MsgBox "رقم  الاسبوع هو :" & " " & st, vbInformation
End Sub

بالتوفيق ....

WEEKDAY.xlsx

تم تعديل مايو 4 بواسطه محمد هشام.

تسجيل الدخول

تجميع فواتير اسبوعيه فى ملف pdf واحد

الردود الموصى بها

عادل ابوزيد

محمد هشام.

عادل ابوزيد

محمد هشام.

عادل ابوزيد

محمد هشام.

عادل ابوزيد

محمد هشام.

عادل ابوزيد

محمد هشام.

عادل ابوزيد

محمد هشام.

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information