مساعدة في الاوفيس طباعة 1500 فاتورة

mr7 · أبريل 19, 2019

السلام عليكم

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

كما في هذه الصورة

الجانب الايمن الفاتورة التي ستطبع الجانب الايسر قائمة الطلبات التي ينقل منها المعلومات الى الفاتورة

( هذه الصفحة فيها 3 فواتير فقط من 1001 الى 1003 كمثال فقط لكن في الواقع عندي 1500 فاتورة مطلوب مني طباعة كل فاتورة على حدى وهي مختلفة بالتاريخ و عدد السطور )

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

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

ملاحظات
اللون الازرق معلومات تم نسخها من صفحة قائمة الطلبات
عدد السطور في الفواتير متغير بعضها يحتوي على ( صنف واحد سطر واحد ) وبعضها ( يتكون من 20 سطر كحد اقصى)
نموذج الفاتورة صغير لان الطباعة سوف تطبع على فواتير صغيرة ( مثل للي في السوبر ماركت )

نسبة الظريبة 5%

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

تم تعديل أبريل 19, 2019 بواسطه mr7

**سليم حاصبيا** · أبريل 20, 2019

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

حمل قسم من الملف حوالي 20 صف لا أكثر( لوضع الكود المناسب ثم يمكن تعميمه على كامل الملف )مهما كان حجم البيانات

mr7 · أبريل 20, 2019

6 ساعات مضت, سليم حاصبيا said:

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

حمل قسم من الملف حوالي 20 صف لا أكثر( لوضع الكود المناسب ثم يمكن تعميمه على كامل الملف )مهما كان حجم البيانات

شكراً على النصحية اخوي سليم

تفضلوا هذا ملف الاكسل بالمرفقات في انتظار تعديل الاساتذة على الملف وشكراً لكم جميعاً

تصميم فاتوة للطبات.xlsx

**سليم حاصبيا** · أبريل 20, 2019

جرب هذا الملف الصفجة Facteur

الكود

Option Explicit
Sub get_data()
Dim dic As Object
Dim dic_key
Dim ro#
Dim i%: i = 2
Dim x_titel#: x_titel = 2
Dim lrDem#
Facteur.Range("H:M").Clear
lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row
 Facteur.Range("Q1") = "رقم الفاتورة"

Dim my_rg As Range
Set my_rg = Demandes.Range("a1:f" & lrDem)
Set dic = CreateObject("scripting.dictionary")
With dic
Do Until Demandes.Cells(i, 1) = vbNullString
If Not .exists(Demandes.Cells(i, 1).Value) Then
 .Add Demandes.Cells(i, 1).Value, ""
End If
i = i + 1
Loop
For Each dic_key In dic.keys
 Facteur.Range("H" & x_titel).Resize(8, 2).Value = Range("Header_Rg").Value
 Range("H" & x_titel + 2).NumberFormat = "0"
 Facteur.Range("Q2") = dic_key
 my_rg.AdvancedFilter 2, Facteur.Range("Q1:Q2"), Facteur.Range("H" & x_titel + 9)
 
 Range("I" & x_titel + 5) = Range("i" & x_titel + 10)
 Range("I" & x_titel + 5).NumberFormat = "d/m/YYY"
 Range("I" & x_titel + 4) = dic_key
 ro = Facteur.Cells(Rows.Count, "H").End(3).Row
 Range("M" & ro + 2) = Evaluate("SUM(M" & x_titel + 10 & ":M" & ro & ")")
 Range("M" & ro + 3).Value = Range("M" & ro + 2) * [D2] / 100
 Range("M" & ro + 4).Value = Range("M" & ro + 2) + Range("M" & ro + 3)

 Range("H" & ro + 2).Resize(3).Value = Range("RESULT").Value
 x_titel = ro + 8
 Next
End With
dic.RemoveAll: Set my_rg = Nothing
Range("Q1:Q2").Clear
End Sub
'=========================
Sub clear_data()
Facteur.Range("H:M").Clear
End Sub
'=========================

Tasmim Fatura.xlsm

mr7 · أبريل 20, 2019

استاذي الكريم سليم

خفتت عني حمل كبير ربي يجازيك عني خير الجزاء

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

والف الف شكرا

**سليم حاصبيا** · أبريل 20, 2019

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

Option Explicit
Sub get_data()
Application.ScreenUpdating = False
Dim dic As Object
Dim dic_key
Dim ro#
Dim i%: i = 2
Dim x_titel#: x_titel = 2
Dim lrDem#
Facteur.Range("H:M").Clear
lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row
 Facteur.Range("Q1") = "رقم الفاتورة"

Dim my_rg As Range
Set my_rg = Demandes.Range("a1:f" & lrDem)
Set dic = CreateObject("scripting.dictionary")
With dic
Do Until Demandes.Cells(i, 1) = vbNullString
If Not .exists(Demandes.Cells(i, 1).Value) Then
 .Add Demandes.Cells(i, 1).Value, ""
End If
i = i + 1
Loop
For Each dic_key In dic.keys
 Facteur.Range("H" & x_titel).Resize(8, 2).Value = Range("Header_Rg").Value
 Range("H" & x_titel + 2).NumberFormat = "0"
 Facteur.Range("Q2") = dic_key
 my_rg.AdvancedFilter 2, Facteur.Range("Q1:Q2"), Facteur.Range("H" & x_titel + 9)
 
 Range("I" & x_titel + 5) = Range("i" & x_titel + 10)
 Range("I" & x_titel + 5).NumberFormat = "d/m/YYY"
 Range("I" & x_titel + 4) = dic_key
 ro = Facteur.Cells(Rows.Count, "H").End(3).Row
 Range("M" & ro + 2) = Evaluate("SUM(M" & x_titel + 10 & ":M" & ro & ")")
 Range("M" & ro + 3).Value = Range("M" & ro + 2) * [D2] / 100
 Range("M" & ro + 4).Value = Range("M" & ro + 2) + Range("M" & ro + 3)

 Range("H" & ro + 2).Resize(3).Value = Range("RESULT").Value
 x_titel = ro + 8
 Next
End With
dic.RemoveAll: Set my_rg = Nothing
Range("Q1:Q2").Clear
Columns("H:M").InsertIndent 1
Application.ScreenUpdating = True
End Sub
'=========================
Sub clear_data()
Facteur.Range("H:M").Clear
End Sub
'=========================
Sub Print_areas()
Application.ScreenUpdating = False
Dim My_Area As Range
Dim last_row#
Dim Serach_RG As Range
Dim find_what$: find_what = "الإجمالي شامل الضريبة"
Dim My_row#, Fix_row#
 Facteur.ResetAllPageBreaks
last_row = Facteur.Cells(Rows.Count, "H").End(3).Row
 If last_row = 1 Then GoTo Leave_Me_Alone
 Set My_Area = Range("H1:M" & last_row)
 Facteur.PageSetup.PrintArea = My_Area.Address
 Set Serach_RG = My_Area.Find(find_what, after:=Range("h2"))
  If Not Serach_RG Is Nothing Then
   My_row = Serach_RG.Row: Fix_row = My_row
   Do
    Facteur.HPageBreaks.Add Before:=Range("H" & My_row + 3)
     Set Serach_RG = My_Area.FindNext(Serach_RG)
     My_row = Serach_RG.Row
     If My_row = Fix_row Then Exit Do
   Loop
   End If
Leave_Me_Alone:
   Application.ScreenUpdating = True
End Sub

الملف الجديد مرفق

Tasmim Fatura_with Printing.xlsm

mr7 · أبريل 21, 2019

ما شاء الله عمل متقن اخي الفاضل

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

لاننا سنستخدم الطابعة حرارية

طلب تعديل بسيط << والله محرج منك بس تحملني

1- حذف رقم الفاتورة وحذف التاريخ من الجدول و الاكتفاء بالتاريخ ورقم الفاتورة في اعلى الفاتورة فقط

2- تغير مكان التاريخ اللي باعلى الفاتورة لتكون ارقام التاريخ اسفل كلمة التاريخ كما في هذا الصورة

شاكر ومقدر وقتك اخي العزيز في مساعدتنا لحل مشاكلنا

دمت في امان الله

Tasmim Fatura_with Printing.xlsm

تم تعديل أبريل 21, 2019 بواسطه mr7

**سليم حاصبيا** · أبريل 21, 2019

تم التعديل كما تريد

Option Explicit
Sub get_data()
Application.ScreenUpdating = False
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
Dim dic_key
Dim ro#
Dim i%: i = 2
Dim x_titel#: x_titel = 2
Dim find_ro#
Dim lrDem#
lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row
Dim my_rg As Range
Set my_rg = Demandes.Range("A1:F" & lrDem)

On Error Resume Next
  Demandes.ShowAllData
 On Error GoTo 0

Facteur.Range("H:M").Clear
lrDem = Demandes.Cells(Rows.Count, 1).End(3).Row
 Facteur.Range("Q1") = "رقم الفاتورة"

With dic
    Do Until Demandes.Cells(i, 1) = vbNullString
            If Not .exists(Demandes.Cells(i, 1).Value) Then
             .Add Demandes.Cells(i, 1).Value, ""
            End If
      i = i + 1
    Loop
 For Each dic_key In dic.keys
       Facteur.Range("H" & x_titel).Resize(8, 2) = _
        Range("Header_Rg").Value
       Range("H" & x_titel + 2).NumberFormat = "0"
       Facteur.Range("Q2") = dic_key
       
       my_rg.AdvancedFilter 1, Facteur.Range("Q1:Q2")
         Demandes.Range("c1:f" & lrDem). _
       SpecialCells(xlCellTypeVisible).Copy _
        Facteur.Range("H" & x_titel + 9)
       
       Application.CutCopyMode = False
       Demandes.ShowAllData
       find_ro = Demandes.Range("A1:A" & lrDem).Find(dic_key).Row
           
           With Range("H" & x_titel + 6)
            .Value = Demandes.Cells(find_ro, 2)
            .NumberFormat = "d/m/YYY"
            .Offset(-2, 1) = dic_key
           End With
          
          ro = Facteur.Cells(Rows.Count, "H").End(3).Row
              Range("K" & ro + 2) = _
                Evaluate("SUM(K" & x_titel + 10 & ":K" & ro & ")")
              Range("H" & ro + 2).Resize(3) = _
                Range("RESULT").Value
              Range("K" & ro + 3) = _
                Range("K" & ro + 2) * [D2] / 100
              Range("K" & ro + 4) = _
                Range("K" & ro + 2) + Range("K" & ro + 3)
           x_titel = ro + 8
  Next dic_key
    .RemoveAll
End With
Set my_rg = Nothing
Range("Q1:Q2").Clear
Columns("H:M").InsertIndent 1
Application.ScreenUpdating = True
End Sub
'=========================
Sub clear_data()
Facteur.Range("H:K").Clear
End Sub
'=========================
Sub Print_areas()
Application.ScreenUpdating = False
Dim My_Area As Range
Dim last_row#
Dim Serach_RG As Range
Dim find_what$: find_what = "الإجمالي شامل الضريبة"
Dim My_row#, Fix_row#
 Facteur.ResetAllPageBreaks
last_row = Facteur.Cells(Rows.Count, "H").End(3).Row
 If last_row = 1 Then GoTo Leave_Me_Alone
 Set My_Area = Range("H1:K" & last_row)
 Facteur.PageSetup.PrintArea = My_Area.Address
 Set Serach_RG = My_Area.Find(find_what, after:=Range("h2"))
  If Not Serach_RG Is Nothing Then
   My_row = Serach_RG.Row: Fix_row = My_row
   Do
    Facteur.HPageBreaks.Add Before:=Range("H" & My_row + 3)
     Set Serach_RG = My_Area.FindNext(Serach_RG)
     My_row = Serach_RG.Row
     If My_row = Fix_row Then Exit Do
   Loop
   End If
Leave_Me_Alone:
   Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Worksheet_Activate()               '
 Dim t%, h%, w%, l%                            '
 h = 40: w = 140: l = 758                      '
 With Me.Shapes.Range(Array("Button 1"))       '
  .Height = h: .Width = w                      '
  .Left = l: .Top = 10                         '
  End With                                     '
  With Me.Shapes.Range(Array("Button 2"))      '
  .Height = h: .Width = w                      '
  .Left = l: .Top = 60                         '
  End With                                     '
  With Me.Shapes.Range(Array("Button 3"))      '
  .Height = h: .Width = w                      '
  .Left = l: .Top = 110                        '
  End With                                     '
End Sub                                        '
''''''''''''''''''''''''''''''''''''''''''''''''

الملف مرفق

Tasmim Fatura_with Printing_Special.xlsm

mr7 · أبريل 21, 2019

تمت بحمد الله اشكرك استاذي الكريم لوقت وجهدك في مساعدتي

دمت في امان الله ورحم الله والديك

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

تم تعديل أبريل 21, 2019 بواسطه mr7

تسجيل الدخول

مساعدة في الاوفيس طباعة 1500 فاتورة

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

mr7

سليم حاصبيا

mr7

سليم حاصبيا

mr7

سليم حاصبيا

mr7

سليم حاصبيا

mr7

Join the conversation

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

تصفح الموقع

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

Support

Important Information