سند الوارد

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

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

انشئ حساب جديد

تسجيل دخول

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

تصفح الموقع

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

Support

Important Information