سند الوارد

husain alhammadi · يناير 31, 2020

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

تم تعديل الملف

و المطلوب هو تفعيل الترحيل من الصرف الى تقريرالصرف

و استدعاء الفاتورة

اخواني الاعضاء

اسمحوا لي

حاولت كثيرا" و لم انجح ارجوا مساعدتي في ذلك

يجب عليك بعد ذلك وضع الأكواد بهذه الطريقة فى المشاركة بالمكان المخصص لها

 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

husain alhammadi · فبراير 1, 2020

تم استخدام الكود

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 = [a9].End(xlUp).Row
 Range("a9:a24").Copy Sheets("تقريرالصرف").Range("a" & Sheets("تقريرالصرف").[a1048576].End(xlUp).Row + 1)
Range("b6").Copy Sheets("تقريرالصرف").Range("b" & Sheets("تقريرالصرف").[b1048576].End(xlUp).Row + 1)
Range("f6").Copy Sheets("تقريرالصرف").Range("c" & Sheets("تقريرالصرف").[c1048576].End(xlUp).Row + 1)
Range("b9:b24").Copy Sheets("تقريرالصرف").Range("d" & Sheets("تقريرالصرف").[d1048576].End(xlUp).Row + 1)
Range("c9:c24").Copy Sheets("تقريرالصرف").Range("e" & Sheets("تقريرالصرف").[e1048576].End(xlUp).Row + 1)
Range("d9:d24").Copy Sheets("تقريرالصرف").Range("f" & Sheets("تقريرالصرف").[f1048576].End(xlUp).Row + 1)
Range("e9:e24").Copy Sheets("تقريرالصرف").Range("g" & Sheets("تقريرالصرف").[g1048576].End(xlUp).Row + 1)
Range("f9:f24").Copy Sheets("تقريرالصرف").Range("h" & Sheets("تقريرالصرف").[h1048576].End(xlUp).Row + 1)
Range("g9:g24").Copy Sheets("تقريرالصرف").Range("i" & Sheets("تقريرالصرف").[i1048576].End(xlUp).Row + 1)
Range("a28").Copy Sheets("تقريرالصرف").Range("j" & Sheets("تقريرالصرف").[j1048576].End(xlUp).Row + 1)
Range("a29").Copy Sheets("تقريرالصرف").Range("k" & Sheets("تقريرالصرف").[k1048576].End(xlUp).Row + 1)
Range("a30").Copy Sheets("تقريرالصرف").Range("l" & Sheets("تقريرالصرف").[l1048576].End(xlUp).Row + 1)
Range("c28").Copy Sheets("تقريرالصرف").Range("m" & Sheets("تقريرالصرف").[m1048576].End(xlUp).Row + 1)
Range("c29").Copy Sheets("تقريرالصرف").Range("n" & Sheets("تقريرالصرف").[n1048576].End(xlUp).Row + 1)
Range("c30").Copy Sheets("تقريرالصرف").Range("o" & Sheets("تقريرالصرف").[o1048576].End(xlUp).Row + 1)
Range("e28").Copy Sheets("تقريرالصرف").Range("p" & Sheets("تقريرالصرف").[p1048576].End(xlUp).Row + 1)
Range("e29").Copy Sheets("تقريرالصرف").Range("q" & Sheets("تقريرالصرف").[q1048576].End(xlUp).Row + 1)
Range("f30").Copy Sheets("تقريرالصرف").Range("r" & Sheets("تقريرالصرف").[r1048576].End(xlUp).Row + 1)
 x = Range("b6").Value
MsgBox "تم ترحيل البيانات بنجاح الى صفحة تقريرالصرف:" & x
  End If
End Sub

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

Range("a9:a24").Copy Sheets("تقريرالصرف").Range("a" & Sheets("تقريرالصرف").[a1048576].End(xlUp).Row + 1)
Range("b6").Copy Sheets("تقريرالصرف").Range("b" & Sheets("تقريرالصرف").[b1048576].End(xlUp).Row + 1)
Range("f6").Copy Sheets("تقريرالصرف").Range("c" & Sheets("تقريرالصرف").[c1048576].End(xlUp).Row + 1)
Range("b9:b24").Copy Sheets("تقريرالصرف").Range("d" & Sheets("تقريرالصرف").[d1048576].End(xlUp).Row + 1)
Range("c9:c24").Copy Sheets("تقريرالصرف").Range("e" & Sheets("تقريرالصرف").[e1048576].End(xlUp).Row + 1)
Range("d9:d24").Copy Sheets("تقريرالصرف").Range("f" & Sheets("تقريرالصرف").[f1048576].End(xlUp).Row + 1)
Range("e9:e24").Copy Sheets("تقريرالصرف").Range("g" & Sheets("تقريرالصرف").[g1048576].End(xlUp).Row + 1)
Range("f9:f24").Copy Sheets("تقريرالصرف").Range("h" & Sheets("تقريرالصرف").[h1048576].End(xlUp).Row + 1)
Range("g9:g24").Copy Sheets("تقريرالصرف").Range("i" & Sheets("تقريرالصرف").[i1048576].End(xlUp).Row + 1)

اخواني بغيت الحل

husain alhammadi · يونيو 9, 2020

للرفع

تسجيل الدخول

سند الوارد

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

husain alhammadi

husain alhammadi

husain alhammadi

Join the conversation

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

تصفح الموقع

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

Support

Important Information