اذهب الي المحتوي
أوفيسنا

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

mr7

بواسطه mr7
في منتدى الاكسيل Excel

 مشاركة

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

mr7

mr7

قام بنشر
قام بنشر (معدل)

السلام عليكم

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

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

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

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

 

 

 

zp1yshZ.jpg

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

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

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

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

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

تم تعديل بواسطه mr7
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

  • Like 1
رابط هذا التعليق
شارك
mr7

mr7

قام بنشر
  • الكاتب
قام بنشر
6 ساعات مضت, سليم حاصبيا said:

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

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

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

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

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

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

جرب هذا الملف الصفجة   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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

  • Like 1
  • Thanks 2
رابط هذا التعليق
شارك
mr7

mr7

قام بنشر
  • الكاتب
قام بنشر (معدل)

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

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

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

9MyUFP5.jpg

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

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

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

cJ4SjOM.png

 

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

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

 

Tasmim Fatura_with Printing.xlsm

تم تعديل بواسطه mr7
  • Like 1
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

  • Like 1
  • Thanks 2
رابط هذا التعليق
شارك
mr7

mr7

قام بنشر
  • الكاتب
قام بنشر (معدل)

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

 

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

 

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

تم تعديل بواسطه mr7
  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept