فاتورة الصرف

[husain alhammadi]

اخواني هل يوجد خطاء في كود الترحيل و التعديل و البحث و فاتورة جديدة

فاتورة كاملة.xlsm

[husain alhammadi]

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

فاتورة كاملة.xlsm

[محمد هشام.]

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

الاكواد ربما لملف آخر وانت تحاول ضبطها على ملفك 

ربما يمكننا مساعدتك عند الإجابة على الإستفسارات التالية:

بالنسبة للترحيل

الملف عليه ارتباط من ملف آخر  لبيانات آمين المستودع والمستلم ورئيس القسم.  يمكنك تحديد عناوين الخلايا لحين كتابة الكود ثم وضع المعادلات الخاصة بك .

B32 D32 G32............ .......

إضافة انك لابد أن توضح هل يتم تكرار نفس البيانات على طول الفاتورة او نسخها في اول صف فقط وكذلك التاريخ 

هل عمود التسلسل في شيت تقرير الصرف يتم نسخه من الفاتورة أم إضافة تسلسل جديد 

بالنسبة للاستعلام 

ماهو شرط البحث هل رقم الصنف مثلا......

 

 

تم تعديل أكتوبر 22, 2023 بواسطه محمد هشام.

[husain alhammadi]

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

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

نعم الاكواد تم اخذها من اليوتيوب  

بالنسبة للترحيل

بالنسبة لللارتباط يمكن ازالتها

البيانات متغيرة حسب الموجود في المستودع 

نعم عمود التسلسل في شيت تقرير الصرف يتم نسخه من الفاتورة 

بالنسبة للاستعلام ماهو شرط البحث و التعديل و استعلام هو رقم الفاتورة

فاتورة كاملة.xlsm

تم تعديل أكتوبر 22, 2023 بواسطه husain alhammadi

[محمد هشام.]

عند ازالة الارتباط لابد من تحديد عناوين الخلايا المراد نسخها الموجودة في الصورة اسفلا  

 

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

[husain alhammadi]

 

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

استاذ محمد هشام لساني يعجز عن شكرك، والكلمات والحروف لا تكفي أن أقدم لك جزيل الشكر والعرفان فجزاك الله خير الجزاء

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

فاتورة كاملة.xlsm

[محمد هشام.]

الظاهر أخي انك لم تستوعب سؤالي  المفروض أنك تنهي تصميم ملفك أولا بالشكل الذي تريده. وتحديد النطاقات والخلايا المطلوب ترحيلها او على الأقل تزويدنا بالشكل المتوقع للبيانات عند الترحيل والاستدعاء حتى نستطيع مساعدتك

يمكنك الاطلاع على المواضيع التالية ربما تفيدك 

 

بالتوفيق

تم تعديل أكتوبر 23, 2023 بواسطه محمد هشام.

[husain alhammadi]

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

اخواني الخبرا هل يوجد خطاء في كود الترحيل

اسم المستخدم :حسين 

كلمة المرور :123

اخى يتم وضع الاكواد بين هذه العلامه

 

Private Sub cmdadd2_Click()
Dim mmm As Integer
mmm = Sheet7.Range("B500").End(xlUp).Row + 1
Sheet7.Cells(mmm, "B").Value = Sheet6.Range("B6").Value
Sheet7.Cells(mmm, "c").Value = Sheet6.Range("F6").Value
Sheet7.Cells(mmm, "d").Value = Sheet6.Range("B9:B27" & lr).Value
Sheet7.Cells(mmm, "e").Value = Sheet6.Range("C9:C27" & lr).Value
Sheet7.Cells(mmm, "f").Value = Sheet6.Range("D9:D27" & lr).Value
Sheet7.Cells(mmm, "g").Value = Sheet6.Range("E9:E27" & lr).Value
Sheet7.Cells(mmm, "h").Value = Sheet6.Range("F9:F27" & lr).Value
Sheet7.Cells(mmm, "I").Value = Sheet6.Range("G9:G27" & lr).Value
Sheet7.Cells(mmm, "J").Value = Sheet6.Range("A31").Value
Sheet7.Cells(mmm, "K").Value = Sheet6.Range("A32").Value
Sheet7.Cells(mmm, "L").Value = Sheet6.Range("A33").Value
Sheet7.Cells(mmm, "M").Value = Sheet6.Range("C31").Value
Sheet7.Cells(mmm, "N").Value = Sheet6.Range("C32").Value
Sheet7.Cells(mmm, "O").Value = Sheet6.Range("C33").Value
Sheet7.Cells(mmm, "P").Value = Sheet6.Range("E31").Value
Sheet7.Cells(mmm, "Q").Value = Sheet6.Range("E32").Value
Sheet7.Cells(mmm, "R").Value = Sheet6.Range("E33").Value
 Sheet6.Range("B6").Value = ""
Sheet6.Range("F6").Value = ""
 Sheet6.Range("B9:B27" & lr).Value = ""
 Sheet6.Range("C9:C27" & lr).Value = ""
 Sheet6.Range("D9:D27" & lr).Value = ""
 Sheet6.Range("E9:E27" & lr).Value = ""
 Sheet6.Range("F9:F27" & lr).Value = ""
 Sheet6.Range("G9:G27" & lr).Value = ""
 Sheet6.Range("A31").Value = ""
Sheet6.Range("A32").Value = ""
 Sheet6.Range("A33").Value = ""
 Sheet6.Range("C31").Value = ""
 Sheet6.Range("C32").Value = ""
 Sheet6.Range("C33").Value = ""
 Sheet6.Range("E31").Value = ""
 Sheet6.Range("E32").Value = ""
 Sheet6.Range("E33").Value = ""


MsgBox "تم ترحيل الفاتورة بنجاح"
End Sub


Private Sub CmdPrint_Click()
Sheet2.Range("A1:G35").PrintPreview
End Sub

 

شاشة الدخول مع صلاحيات المستخدمين.xlsb

تم تعديل أكتوبر 23, 2023 بواسطه husain alhammadi

[محمد هشام.]

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

 على العموم اخي يمكننا العمل خطوة خطوة  للوصول للنتيجة المطلوبة سوف نشتغل على اول شيت وهو ورقة 5 مع ترحيل البيانات الى ورقة 6 .

يمكنك بعد دالك نسخ نفس الاكواد مع تغيير اسماء اوراق العمل فقط 

اول خطوة هتدخل على حدث ورقة 5 وتمسح جميع الاكواد السابقة وتقوم بتعويضها بالتالي 

تم انشاء كود الترحيل والطباعة مع بعض الاظافات التي من الممكن ان تساعدك على العمل على الملف بشكل افضل 

بالنسبة للاستدعاء طريقة وضعك للمعادلات بورقة الادخال لن تمكنك من استدعاء البيانات في نفس الموضع يمكنك انشاء ورقة خاصة بدالك او تعويض الصيغ بالاكواد 

 

 *****ترحيل******
Private Sub cmdadd2_Click() 
Dim wsdata     As Worksheet
Dim wsdest     As Worksheet
Dim Rng1 As Range, Rng2 As Range

Set wsdata = ThisWorkbook.Sheets("Sheet5")
Set wsdest = ThisWorkbook.Sheets("Sheet6")
Dim A, B, C, D, E, F, J, k, L, The_Date, N_invoice, The_Currency As String

Set Rng1 = wsdata.Range("A9:G28")
Set Rng2 = wsdata.Range("A32,C32,E32")


  The_Date = Date: N_invoice = wsdata.[F7]: The_Currency = "د" & "." & "إِ."
    A = wsdata.[A32]: B = wsdata.[A33]: C = wsdata.[A34]
     D = wsdata.[C32]: E = wsdata.[C33]: F = wsdata.[C34]
      J = wsdata.[E32]: k = wsdata.[E33]: L = wsdata.[E33]


Arr = Array([B9], [C9], [D9], [E9], [F9], [G9], [A32], [C32], [E32])
    For i = 0 To 8
        If Arr(i) = Empty Then
        
        
msg = MsgBox("يرجى ملء بيانات" & " " & Arr(i).Offset(-1, 0), vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "Admin")
            Arr(i).Select
            Exit Sub
        End If
      
    Next
If Not IsNumeric(N_invoice) Or N_invoice = 0 Then MsgBox "المرجوا ادخال رقم الفاتورة", vbExclamation, "Admin": Exit Sub
If Application.WorksheetFunction.CountIf(wsdest.Range("C:C"), wsdata.[F7].Value) > 0 Then MsgBox "رقم الفاتورة موجود مسبقا", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin": Exit Sub
       
msg = MsgBox("ترحيل البيانات  ؟", vbYesNo + vbQuestion, "Admin")
        If msg = vbYes Then
        
Application.ScreenUpdating = False

    col = Rng1
    For i = 1 To UBound(col)
       If Len(col(i, 2)) > 0 Then
wsdest.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(1, 17).Value _
= Array(The_Date, N_invoice, (col(i, 2)), (col(i, 3)), (col(i, 4)), (col(i, 5)), (col(i, 6)), The_Currency & (col(i, 7)), A, B, C, D, E, F, J, k, L)

On Error Resume Next '
    Union(Rng1, Rng2).SpecialCells(xlCellTypeConstants).ClearContents
      N_invoice.Value = N_invoice.Value + 1
    
    With wsdest.Range("A9:A" & wsdest.Cells(Rows.Count, "B").End(xlUp).Row)
        .Value = Evaluate("ROW(" & .Address & ")-8")
           wsdata.[F7].Value = wsdest.Range("C" & Rows.Count).End(xlUp).Value + 1
         End With
End If
Next
Call Add_border
wsdata.Activate
Application.ScreenUpdating = True
  msg = MsgBox("تم ترحيل البيانات بنجاح", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "Admin")
End If
End Sub

 *****فاتورة جديدة******

Private Sub CommandButton1_Click()
Dim msg As VbMsgBoxResult
Dim MyRng      As Range
Set wsdata = ThisWorkbook.Sheets("Sheet5")
Set MyRng = wsdata.Range("A9:G28")
msg = MsgBox("هل انت مناكد من افراغ البيانات ؟ ", vbYesNo + vbQuestion + vbDefaultButton2, "انتباه")
If msg = vbYes Then
On Error Resume Next
Application.ScreenUpdating = False
MyRng.SpecialCells(xlCellTypeConstants).ClearContents
wsdata.Range("A32,C32,E32").Value = Empty
On Error GoTo 0
End If
End Sub

Private Sub Worksheet_Activate()
 Set ws1 = ThisWorkbook.Sheets("Sheet5")
 Set ws2 = ThisWorkbook.Sheets("Sheet6")
Application.ScreenUpdating = False
On Error Resume Next
If Len(ws2.Range("C9").Value) <> Empty Then
 ws1.[F7].Value = ws2.Range("C" & Rows.Count).End(xlUp).Value + 1
 End If
End Sub
 *****ترقيم عمود (A)******
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
If Not Intersect(Target, Range("B9:B28")) Is Nothing Then
Application.EnableEvents = False
    AddNumbering
Application.EnableEvents = True
End If
On Error GoTo 0
End Sub

Private Sub CmdPrint_Click()
Print_invoice
End Sub

وفي module  جديد انسخ الاكواد التالية

Sub Print_invoice()
' طباعة
Dim sh As Worksheet, i As Long
Set sh = ActiveSheet
If Application.WorksheetFunction.CountA(sh.Range("B9:B28")) = 0 Then
msg = MsgBox("ليس هناك بيانات للطباعة", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin")
        Exit Sub
    End If
For i = 9 To 28
Application.ScreenUpdating = False

    If Cells(i, 1) = "" And Cells(i, 2) = "" Then
    Cells(i, 1).EntireRow.Hidden = True
   End If
 Next
 sh.PageSetup.PrintArea = "A1:G35"
 ActiveWindow.SelectedSheets.PrintOut
 Range("A9:A28").EntireRow.Hidden = False
End Sub
Sub AddNumbering()
' ترقيم
Dim MyDest As Worksheet: Set MyDest = Sheet5
Dim F As Range, R As Range
Set D = MyDest.Range("A9:A28")
Set F = MyDest.Range("B9:B28")
 D.ClearContents
For Each R In F
        If R.Value <> "" Then
         J = J + 1
         R.Offset(0, -1).Value = Format(J, "0")
         End If
       Next
End Sub
Sub Add_border()
' تسطير البيانات
Dim rng As Range, cell As Range
Dim sh As Worksheet: Set sh = Sheet6

Application.ScreenUpdating = False
sh.Activate
dl = sh.Range("A:R").Find("*", , , , xlByRows, xlPrevious).Row
'Sh.Range("a9:R" & dl).Borders.LineStyle = xlNone
    sh.Range("A9:R1000").Borders.LineStyle = xlNone
    dc = sh.Cells(9, Columns.Count).End(xlToLeft).Column
    
Set rng = sh.Range(Cells(9, 1), sh.Cells(dl, dc))
   For Each cell In rng
    With cell
       .Borders.Weight = xlThin
       .Borders.ColorIndex = 5
     End With
 Next cell
End Sub

 

شاشة الدخول مع صلاحيات 3.xlsb

تم تعديل أكتوبر 24, 2023 بواسطه محمد هشام.

[husain alhammadi]

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

ذهبت إلى أبعد الحدود معنا، فأنت تهتم حقًا بتقديم الأفضل لنا، شكرًا لك من أعماق قلوبنا.

لقد رفعت مستوايَ عاليًا، وعلّمتني أكثر مما اعتقدت، شكرًا لك أستاذي.
 

[محمد هشام.]

 الغفو اخي يسعدني  حقا انني استطعت مساعدتك 

 تفضل لقد تم تصحيح الاكواد الدي قمت باظافتها  انت على اخر ملف مرفوع على المنتدى وتفعيلها على ورقة 7 و8 

 

 

 

شاشة الدخول مع صلاحيات 4.xlsb

تم تعديل أكتوبر 24, 2023 بواسطه محمد هشام.

[husain alhammadi]

لقد رفعت مستوايَ عاليًا، وعلّمتني أكثر مما اعتقدت، شكرًا لك أستاذي محمد هشام. لقد جعلتني أكتشف أنني أذكى مما كنت أعتقد، وأنه لا بأس بالفشل طالما أنني أحاول مجددًّا، شكرًا على كل شيء