husain alhammadi

السلام و رحمة الله و بركاتة تم تعديل الملف و المطلوب هو تفعيل الترحيل من الصرف الى تقريرالصرف و استدعاء الفاتورة اخواني الاعضاء اسمحوا لي حاولت كثيرا" و لم انجح ارجوا مساعدتي في ذلك يجب عليك بعد ذلك وضع الأكواد بهذه الطريقة فى المشاركة بالمكان المخصص لها Sub طباعة() Sheet13.Range("A1:G35").PrintPreview End Sub Private Sub CommandButton1_Click() Dim ws As Worksheet, sh As Worksheet, LR As Long, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("الصرف") Set sh = ThisWorkbook.Worksheets("تقريرالصرف") LR = Application.Max(9, ws.Range("B9").End(xlDown).Row) If LR < 9 Then Exit Sub m = sh.Cells(Rows.Count, 1).End(xlUp)(2).Row sh.Range("A" & m).Resize(LR - 8).Value = ws.Range("A9:G24" & LR).Value sh.Range("B" & m).Resize(LR - 8).Value = ws.Range("B6").Value sh.Range("C" & m).Resize(LR - 8).Value = ws.Range("F6").Value sh.Range("D" & m).Resize(LR - 8, 6).Value = ws.Range("B9:G24" & LR).Value ws.Range("A9:G24").SpecialCells(xlCellTypeConstants).Cells.ClearContents Application.ScreenUpdating = True End Sub Sub newInvoice() xx = Sheets("الصرف").[A999999].End(xlUp) If IsNumeric(xx) Then n = xx + 1 Else n = 200001 [F6] = n End Sub Sub مسح_الفاتورة() Reply = MsgBox(" هام جداً " & Chr(10) & "هل تريد مسح البيانات ", vbYesNo) 'ActiveSheet.Unprotect (123) If Reply <> 6 Then Exit Sub Range("b6") = "" Range("g6") = "" Range("b9:b24") = "" Range("c9:c24") = "" Range("d9:d24") = "" Range("e9:e24") = "" Range("f9:f24") = "" Range("g9:g24") = "" Range("c25") = "" Range("g25") = "" Range("a28:a30") = "" Range("c28:c30") = "" Range("e28:e30") = "" 'ActiveSheet.Protect (123) End Sub Sub استدعاء_فاتورة_من_الفواتير() Dim Filename As String Filename = Range("B6").Value Workbooks.Open ("e:\الفواتير\" & Filename & ".xlsm") End Sub Sub حفظ_في_الاستعلام() Dim Extension$, savePathName As String If Cells(1, 6) = "" Or Cells(1, 2) = "" Then MsgBox "من فضلك ادخل نوع الفاتورة ", vbOKOnly, " تنبيه": Exit Sub Ayadah = Cells(1, 6) Extension = Cells(1, 2) & ".xls" savePathName = "d:\المطلوب\قيد التنفيز\الشغل الخلصان\" & Ayadah & "\" On Error Resume Next Application.DisplayAlerts = False GetAttr (savePathName) Select Case Err.Number Case Is = 0 Application.DisplayAlerts = False ThisWorkbook.SaveCopyAs savePathName & Extension MsgBox "الاسم موجود مسبقاً وتم إضافة العمل فيه", vbOKOnly, "تنبيه" Application.DisplayAlerts = True Case Else MkDir savePathName ThisWorkbook.SaveCopyAs savePathName & Extension MsgBox "تم انشاء فلدر وحفظ العمل فيه", vbOKOnly, "تنبيه" End Select On Error GoTo 0 End Sub Sub حفظ_الفاتورة() 'Private Sub CommandButton2_Click() Reply = MsgBox(" هل تريد" & Chr(10) & " حفظ الفاتورة ", vbYesNo) 'هنا هل تريد طبع النسخ ام لا If Reply <> 6 Then Exit Sub If Cells(1, 7) = "" Or Cells(1, 2) = "" Then MsgBox " من فضلك ادخل اسم العميل- ونوع الفاتورة ", vbOKOnly, " تنبيه": Exit Sub Ayadah = Cells(1, 7) Extension = Cells(1, 2) & ".xls" If Cells(1, 2).Value = "" Then ' اسم المجلد ' MsgBox "يجب عليك إتباع ما يلي " & vbNewLine & vbNewLine & " كتابة اسم الملف " & vbNewLine & " كتابة اسم المجلد " & vbNewLine & vbNewLine & "ثم الضغط على حفظ", vbInformation + vbMsgBoxRight, "خطأ" Exit Sub Else Dim MyPathDirectory, MyNime On Error GoTo MSG MyPathDirectory = Cells(1, 10).Text & ":\" & Cells(1, 2).Text 'هذ الستر لو تحدد اي مجلد للحفظ علية MyPathDirectory = Cells.Text & "d:\OneDrive\المطلوب\" & Cells(1, 2).Text & Nombre & " " & Format(Now, " dd-mm-yyyy") & "" ' MyPathDirectory = Cells.Text & "h:\حساب يوم بيوم\" & Cells(1, 2).Text & Nombre & " " & Format(Now, " dd-mm-yyyy") & "" 'هنا تحديد مكان الحفظ' MyNime = "\" & Cells(1, 2).Text & ".xls" '°°° If Dir(MyPathDirectory & MyNime) > "" Then MsgBox "هذا الملف موجود مسبقا يجب اختيار مسار آخر", vbCritical, "Faute" MkDir (MyPathDirectory) ActiveWorkbook.SaveCopyAs MyPathDirectory & MyNime x = Range("b1").Value MsgBox "تم حفظ فاتورة:" & x Application.ScreenUpdating = False With Sheets("Sheet13") 'هنا حدد الشيت المراد طباعتة' Dim ss As String ss = "‎Send To OneNote 2016 على ‎nul:" With .UsedRange For i = 1 To .Rows.Count If .Cells(i, 1).Value = "" Then .Cells(i, 1).EntireRow.Hidden = True '-c معتمد علي العمود 'هذا الستر الذي يمنع الفراغ End If Next i End With .PrintOut Rows.Hidden = False End With MSG: Reply = MsgBox(" هام جداً " & Chr(10) & "هل تريد مسح البيانات ", vbYesNo) If Reply <> 6 Then Exit Sub Range("b6") = "" Range("g6") = "" Range("b9:b24") = "" Range("c9:c24") = "" Range("d9:d24") = "" Range("e9:e24") = "" Range("f9:f24") = "" Range("g9:g24") = "" Range("c25") = "" Range("g25") = "" Range("a28:a30") = "" Range("c28:c30") = "" Range("e28:e30") = "" 'ActiveSheet.Unprotect (123) Range("b6").Value = Range("b6").Value + 1 'ActiveSheet.Protect (123) End If End Sub Sub احضار_الاصناف() Reply = MsgBox(" هام جداً " & Chr(10) & "هل تريد بيانات الصنف ", vbYesNo) If Reply <> 6 Then Exit Sub Sheets("Sheet16").Activate 'هنا تحديد اسم الشيت الذي به البينات' Dim LR As Integer LR = [b1].End(xlUp).Row Range("b9:e9" & LR).Copy Sheets(1).Activate Range("C" & [b9].End(xlUp).Row + 7).PasteSpecial xlPasteValues Sheets(1).Activate 'MsgBox "تم احضار بيانات الصنف " End Sub Sub ترحيل_الفواتير() If Range("b6").Value = False Then MsgBox "من فضلك ادخل جميع البيانات " Else Dim lastrow As Integer Reply = MsgBox("هل رقم الفاتورة: " & Range("B6").Value & Chr(10) & " مسجل مسبقاً", vbYesNo) 'هنا هل تريد طبع النسخ ام لا If Reply <> 6 Then Exit Sub lastrow = [a4].End(xlUp).Row Range("a1:m2" & lastrow).Copy Sheets("تقريرالصرف").Range("a" & Sheets("تقريرالصرف").[a1048576].End(xlUp).Row + 2) Range("i2").Value = Range("i2").Value + 1 x = Range("b6").Value MsgBox "تم ترحيل البيانات بنجاح الى صفحة:" & x Reply = MsgBox(" هام جداً " & Chr(10) & "هل تريد مسح البيانات ", vbYesNo) If Reply <> 6 Then Exit Sub Range("b6") = "" Range("g6") = "" Range("b9:b24") = "" Range("c9:c24") = "" Range("d9:d24") = "" Range("e9:e24") = "" Range("f9:f24") = "" Range("g9:g24") = "" Range("c25") = "" Range("g25") = "" Range("a28:a30") = "" Range("c28:c30") = "" Range("e28:e30") = "" End If 'Range("a4:h4" & lastrow).ClearContents End Sub الفاتورة 1.xlsm

السلام عليكم و رحمة الله و بركاتة ارفق لكم ملف اكسل خاص بالمستودع C8 D8 E8 F8 I11 من شيت بيانات الاصناف B11 بداية السنة المالية و هو ثابت لجميع الاصناف B12 الى E12 من شيت تقريرالوارد B12 و F13 G13 H13 من شيت تقريرالوارد اخواني الاعضاء ارجو منكم تصحيح الكود بطاقة الصنف بالملف المرفق و جزاكم الله خير Copy of Book2.zip