محمد هشام.

لم يتم اخي الفاضل اظافة الكود انا في انتظار الرد على سؤالي ما هي طريقة ترحيل المشتريات هل سيتم النسخ الى صفحات المخازن وورقة المشتريات دفعة واحدة مع تحديث الكود او مادا على العموم على حسب ما فهمت الى غاية اللحظة ربما هدا ما تحاول فعله Sub TransferData2() Dim i As Long, Cnt As Long Dim ws As Worksheet, f As Worksheet, sWS As Worksheet Dim Sh As String, arr As Variant Dim tbl As ListObject, a As Range, lige As Range Dim j As String, newCode As String, b As String Set ws = ThisWorkbook.Sheets("تسجيل") Sh = ws.[G3].Value arr = Array(ws.[G4], ws.[G5], ws.[G6], ws.[G7]) For i = 0 To 3 If arr(i) = "" Then MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه" ws.Activate: arr(i).Select Exit Sub End If Next On Error Resume Next Set f = ThisWorkbook.Sheets(Sh) On Error GoTo 0 If f Is Nothing Then MsgBox "قائمة المخزون " & Sh & " غير موجودة", vbExclamation Exit Sub End If If MsgBox("هل ترغب في ترحيل بيانات التسجيل؟", vbYesNo + vbQuestion, "تأكيد الترحيل") = vbNo Then Exit Sub Set tbl = f.ListObjects(1) On Error Resume Next Set lige = tbl.ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeConstants).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) On Error GoTo 0 ' الكود الجديد If Not lige Is Nothing Then j = lige.Value b = Left(j, Len(j) - Len(CStr(Val(j)))) Cnt = Val(Right(j, Len(j) - Len(b))) newCode = b & Cnt + 1 Else newCode = ws.[G4].Value End If If Not lige Is Nothing Then Set a = lige.Offset(1, 0) Else Set a = tbl.ListColumns(2).DataBodyRange.Cells(1, 1) If a.Value <> "" Then Set a = tbl.ListColumns(2).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1) End If End If a.Value = newCode ' الكود a.Offset(0, 5).Value = 1 ' الكمية a.Offset(0, 2).Value = arr(1) ' الاسم a.Offset(0, 3).Value = arr(2) ' الوصف a.Offset(0, 7).Value = arr(3) ' الملاحظات a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ Set sWS = Sheets("المشتريات") Set tbl = sWS.ListObjects(1) On Error Resume Next Set lige = tbl.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) On Error GoTo 0 If Not lige Is Nothing Then Set a = lige.Offset(1, 0) Else Set a = tbl.ListColumns(3).DataBodyRange.Cells(1, 1) If a.Value <> "" Then Set a = tbl.ListColumns(3).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1) End If End If a.Cells(1, 1).Offset(0, -1).Value = Format(Date, "dd/mmmm") ' التاريخ a.Value = newCode ' الكود a.Offset(0, 5).Value = 1 ' الكمية a.Offset(0, 2).Value = arr(1) ' الاسم a.Offset(0, 3).Value = arr(2) ' الوصف a.Offset(0, 7).Value = arr(3) ' الملاحظات a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ End Sub مبيعات ومشتريات V1.xlsb

تم تعديلها مع اظافة امكانية جلب اخر كود في الصفحة الهدف عند التغيير في الخلية G3 جرب هدا للمبيعات Sub TransferData1() Dim ws As Worksheet, dest As Worksheet, sWS As Worksheet Dim arr As Variant, xdate As String Dim Clé As String, a As Range, n As Range Dim Sht As String, tbl2 As ListObject, Irow As Range xdate = Format(Date, "dd/mmmm") Set ws = Sheets("تسجيل") Sht = ws.Range("C3").Value On Error Resume Next Set dest = Sheets(Sht) On Error GoTo 0 If dest Is Nothing Then MsgBox "صفحة المخازن" & Sht & " غير موجودة", vbExclamation Exit Sub End If Set sWS = Sheets("المبيعات") Clé = ws.Range("C4").Value arr = Array(ws.Range("C4").Value, ws.Range("C5").Value, ws.Range("C6").Value, ws.Range("C7").Value) For i = 0 To 3 If arr(i) = "" Then MsgBox "يرجى إدخال: " & ws.Cells(4 + i, 2).Value, vbExclamation, "تنبيه" ws.Activate ws.Cells(4 + i, 3).Select Exit Sub End If Next i Set a = dest.Columns("C").Find(What:=Clé, After:=dest.Cells(4, 3), LookIn:=xlValues, LookAt:=xlWhole) If a Is Nothing Then MsgBox "لم يتم العثور على ُمعرّف المخزون " & Clé, vbExclamation Exit Sub End If a.Offset(0, 2).Value = arr(1) a.Offset(0, 6).Value = arr(2) a.Offset(0, 7).Value = arr(3) a.Offset(0, 5).Value = 1 a.Offset(0, 9).Value = xdate Set tbl2 = sWS.ListObjects(1) Set Irow = tbl2.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) If Not Irow Is Nothing Then Set n = Irow.Offset(1).Resize(1, tbl2.ListColumns.Count) Else Set n = tbl2.ListRows(1).Range.Resize(1, tbl2.ListColumns.Count) End If n.Cells(1, 1).Offset(0, -1).Value = xdate n.Cells(1, 1).Resize(1, 10).Value = a.Resize(1, 10).Value MsgBox "تم ترحيل البيانات بنجاح", vbInformation End Sub بالنسبة للمشتريات هل الترحيل للورقة المختارة او لورقة المشتريات مع مراعات تسلسل كود الصنف مبيعات ومشتريات V1.xlsb

ادن ما نفهمه الان انك رغم ادخالك مثلا w3 يتم تجاهله واظافة كود جديد w4

انا بتكلم عند الترحيل الى صفحات المخزون هناك شيء غير مفهوم لكي نكون اكثر وضوحا جرب هدا لترحيل البيانات الى صفحات المخزون وورقة المبيعات ووافيني بالنتيجة Sub CopyDatasale() Dim ws As Worksheet, f As Worksheet, dest As Worksheet Dim Sh As String, arr As Variant, rngToCopy As Range Dim tbl As ListObject, Tbl2 As ListObject, i& Dim OnRng As Range, Irow As Range, a As Range, n As Range Set ws = Sheets("تسجيل") Set dest = Sheets("المبيعات") Sh = ws.[C3].Value: Set f = ThisWorkbook.Sheets(Sh) arr = Array(ws.[C4], ws.[C5], ws.[C6], ws.[C7]) For i = 0 To 3 If arr(i) = "" Then MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه": ws.Activate: arr(i).Select: Exit Sub Next On Error Resume Next Set f = ThisWorkbook.Sheets(Sh) On Error GoTo 0 If f Is Nothing Then MsgBox "قائمة المخزون " & Sh & " غير موجودة", vbExclamation Exit Sub End If Dim MSg As VbMsgBoxResult MSg = MsgBox("هل ترغب في ترحيل بيانات التسجيل؟", vbYesNo + vbQuestion, "تأكيد الترحيل") If MSg = vbNo Then Exit Sub Set tbl = f.ListObjects(1) Set Tbl2 = dest.ListObjects(1) Set OnRng = tbl.ListColumns(2).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) If Not OnRng Is Nothing Then Set a = OnRng.Offset(1) Else Set a = tbl.ListRows(1).Range End If '==== ترحيل البيانات إلى ورقة المخزون ===== a.Cells(1, 1).Value = arr(0) ' كود الصنف a.Cells(1, 3).Value = arr(1) ' الاسم a.Cells(1, 6).Value = 1 ' الكمية a.Cells(1, 4).Value = arr(2) ' الوصف a.Cells(1, 8).Value = arr(3) ' الملاحظات a.Cells(1, 10).Value = Format(Date, "dd/mmmm") ' التاريخ Set OnRng = tbl.ListColumns(2).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) Set Irow = Tbl2.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) If Not Irow Is Nothing Then Set n = Irow.Offset(1).Resize(1, 10) Else Set n = Tbl2.ListRows(1).Range.Resize(1, 10) End If '==== ترحيل البيانات إلى ورقة المبيعات ===== Set rngToCopy = OnRng.Resize(1, 10) n.Value = rngToCopy.Value n.Cells(1, 1).Offset(0, -1).Value = Format(Date, "dd/mmmm") End Sub

يعني مسالة تكرار الكود واردة

صراحة اخي ما فهمته لحد الساعة ان الادخال في ورقة تسجيل سواءا للمبيعات او المشتريات يتم ترحيلهم الى قوائم المخازن وفي حالة كان الترحيل عبر المبيعات يتم الترحيل لصفحة المخازن المحددة مع نفس البيانات الى ورقة المبيعات للاعمدة التي دكرت ادا كان هدا صحيحا . حتى لو اشتغلنا على عدم تكرار الاكواد عند الادخال في الحقول الخاصة بالشراء عند ادخال بيانات المبيعات هناك عدة احتمالات واردة مادا لو قمت باختيار كود صنف موجود مسبقا سيتم تكرار الكود هناك احتمالية الاستغناء عن خلية ادخال الكود وتعويضها داخل الكود بانشاء تسلسل تلقائي للاكواد اي جلب اخر كود تم ترحيله مع اظافة +1 لهدا يصعب التعامل مع الملف في غياب معطيات كافية بالتفصيل

وعليكم السلام ورحمة الله تعالى وبركاته حياك الله اخي @عبدالله بشير عبدالله اسمح لي بهدا الاقتراح اخي @hussam031 قم بوضع احدى المعادلات التالية في الخلية C12 مع سحبها يسارا لغاية اخر عمود K =SUMPRODUCT(C$3:C$9, INDEX(RawMaterials!$C$2:$C$100, MATCH($B$3:$B$9, RawMaterials!$B$2:$B$100, 0))) OR =SUMPRODUCT(C$3:C$9, VLOOKUP($B$3:$B$9, RawMaterials!$B$2:$C$100, 2, FALSE)) officena V2.xlsx

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

عبد إذن أخونا الفاضل @عبدالله بشير عبدالله بطريقة مختصرة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$B$6" Then Application.ScreenUpdating = False Dim f As Worksheet, WS As Worksheet, search As String, tmp As Range, Lr As Long, i As Integer Set f = Sheets("السجل") Set WS = Sheets("استدعاء") search = WS.Range("B6").Value If search = "" Then Exit Sub Lr = f.Cells(f.Rows.Count, "B").End(xlUp).Row Set tmp = f.Range("B2:B" & Lr).Find(search, LookIn:=xlValues, LookAt:=xlWhole) If Not tmp Is Nothing Then For i = 0 To 3 WS.Range("A" & 9 + i * 3 & ":I" & 9 + i * 3).Value = _ f.Range(tmp.Offset(0, i * 9 + 1), tmp.Offset(0, (i + 1) * 9)).Value Next i Else MsgBox "الإسم غير موجود في السجل" End If Application.ScreenUpdating = True End If End Sub OR If Not tmp Is Nothing Then For i = 1 To 4 '(i - 1) * 9 لإزاحة النطاق المنسوخ 9 أعمدة في كل مرة '(i - 1) * 3 تحريك الصفوف بمقدار 3 صفوف في كل مرة WS.Range("A" & 9 + (i - 1) * 3 & ":I" & 9 + (i - 1) * 3).Value = _ f.Range(tmp.Offset(0, (i - 1) * 9 + 1), tmp.Offset(0, i * 9)).Value Next i Else

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

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام كدالك Sub addFormula() Dim lr& With ThisWorkbook.Sheets("Sheet1") lr = .Cells(.Rows.Count, "G").End(xlUp).Row .Range("H2:H" & lr).Formula2 = "=COUNTIF(G$2:G" & lr & ", G2)" End With End Sub ولتنفيده عند التغيير تلقائيا مع اظافة المعادلة الموجودة في عمود G يمكنك وضع الكود التالي في حدث Sheet1 Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim lr As Long lr = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row 'column (G) With Me.Range("G2:G" & lr) .Formula2 = "=TEXTJOIN(""-"", TRUE, A2, C2)" .Value = .Value End With 'column (H) With Me.Range("H2:H" & lr) .Formula2 = "=COUNTIF(G$2:G" & lr & ", G2)" .Value = .Value End With Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.EnableEvents = True End Sub

الفكرة بالنسبة للمبيعات هي عند اختيار اسم صفحة المخزون من الخلية C3 سيتم انشاء قائمة منسدلة بأكواد الصنف المتوفرة في نفس الصفحة المختارة تلقائيا لتسهيل عملية البحث وعند اختيار كود الصنف يتم جلب اسم الصنف وبعد ادخال السعر والملاحظات والظغط على زر الترحيل يتم ترحيل بيانات التسجيل الى الصفحة المختارة مع ترحيل نفس البيانات الى ورقة المبيعات في الاعمدة المناسبة و اظافة تاريخ اليوم في العمود الاول من الجدول المشتريات بعد تحديد الصفحة الهدف من الخلية G3 واظافة بيانات التسجيل كود الصنف- اسم الصنف-السعر-الملاحظات يتم ترحيلها الى الصفحة المحددة مع نسخ نفس البيانات المتاحة لجدول المشتريات في الاعمدة المناسبة ادا كانت قد فهمت طلبك بشكل صحيح فهدا سيوفي بالغرض تم دمج اكواد الترحيل لجميع الصفحات في الكود التالي Sub CopyDatasale() Call ProcessTransfer("تسجيل", "المبيعات", Array(1, 2, 7, 8), Array(2, 3, 8, 9), True) End Sub Sub CopyDatabuy() Call ProcessTransfer("تسجيل", "المشتريات", Array(1, 2, 7, 8), Array(1, 2, 7, 8), False) End Sub '======================================= Sub ProcessTransfer(registrationSheetName As String, destName As String, _ stockColumnsArr As Variant, salesColumnsArr As Variant, Cnt As Boolean) Dim WS As Worksheet, f As Worksheet, dest As Worksheet Dim arr As Variant, list As String, MSg As VbMsgBoxResult Dim i As Long Set WS = ThisWorkbook.Sheets(registrationSheetName) Set dest = ThisWorkbook.Sheets(destName) If destName = "المشتريات" Then arr = Array(WS.[G4], WS.[G5], WS.[G6], WS.[G7]) list = WS.[G3].Value Else arr = Array(WS.[C4], WS.[C5], WS.[C6], WS.[C7]) list = WS.[C3].Value End If For i = 0 To 3 If arr(i) = "" Then MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه" arr(i).Select Exit Sub End If Next On Error Resume Next Set f = ThisWorkbook.Sheets(list) On Error GoTo 0 If f Is Nothing Then MsgBox "قائمة المخزون " & list & " غير موجودة", vbExclamation Exit Sub End If If MsgBox("ترحيل البيانات؟", vbYesNo + vbQuestion, "تأكــيد") = vbNo Then Exit Sub RegistrationData f, arr, stockColumnsArr RegistrationData dest, arr, salesColumnsArr, Cnt MsgBox list & ": تم ترحيل البيانات بنجاح إلى " & destName & " وقائمة المخزون", vbInformation MSg = MsgBox("هل ترغب في إفراغ بيانات التسجيل؟", vbYesNo + vbQuestion, "تفريغ الخلايا") If MSg = vbYes Then If destName = "المشتريات" Then WS.[G3:G7].ClearContents Else WS.[C3:C7].ClearContents End If End If End Sub '======================================= Sub RegistrationData(sheet As Worksheet, arr As Variant, columnsArr As Variant, Optional Cnt As Boolean = False) Dim tbl As ListObject, lige As Range, TabBD As Range, i As Long Set tbl = sheet.ListObjects(1) Set lige = tbl.ListColumns(2).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) Set TabBD = IIf(lige Is Nothing, tbl.ListRows(1).Range, lige.Offset(1)) If Cnt Then TabBD.Cells(1, 1).Value = Format(Date, "dd/mmmm") End If For i = LBound(arr) To UBound(arr) TabBD.Cells(1, columnsArr(i)).Value = arr(i).Value Next i End Sub وفي حدث ورقة التسجيل ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim dest As Worksheet, i As Long, lastRow As Long, TabBD As Boolean, Sh As String, itemCode As String, _ dict As Object, CRng As Range, a As Variant, tmp As Variant Dim WS As Worksheet: Set WS = Sheets("تسجيل") On Error GoTo ErrorHandler Sh = Me.Range("C3").Value itemCode = Me.Range("C4").Value TabBD = False If Sh = "" Then Exit Sub Application.ScreenUpdating = False Application.EnableEvents = False Select Case Target.Address Case Me.Range("C3").Address If Not Check(Sh, dest) Then TabBD = True Else lastRow = dest.Cells(dest.Rows.Count, "C").End(xlUp).Row Set CRng = dest.Range("C4:C" & lastRow) tmp = CRng.Value Set dict = CreateObject("Scripting.Dictionary") For i = 1 To UBound(tmp, 1) If tmp(i, 1) <> "" And Not dict.Exists(tmp(i, 1)) Then dict.Add tmp(i, 1), Nothing End If Next i With WS.Range("L3:L" & WS.Cells(WS.Rows.Count, "L").End(xlUp).Row) .ClearContents End With If dict.Count > 0 Then With WS.Range("L3").Resize(dict.Count) .Value = Application.Transpose(dict.Keys) End With End If WS.Range("C4:C5").Value = "" Call Add_listeDéroulante End If Case Me.Range("C4").Address If Sh = "" Or itemCode = "" Then TabBD = True Else If Not Check(Sh, dest) Then TabBD = True Else lastRow = dest.Cells(dest.Rows.Count, "C").End(xlUp).Row Set CRng = dest.Range("C4:C" & lastRow) tmp = CRng.Value a = Application.Match(itemCode, Application.Index(tmp, 0, 1), 0) If Not IsError(a) Then WS.Range("C5").Value = dest.Cells(a + 3, "D").Value Else WS.Range("C5").Value = "" TabBD = True End If End If End If End Select ExitHandler: Application.EnableEvents = True Application.ScreenUpdating = True Exit Sub ErrorHandler: MsgBox "Error : " & Err.Description, vbExclamation TabBD = True Resume ExitHandler End Sub Function Check(sheetName As String, ByRef dict As Worksheet) As Boolean On Error Resume Next Set dict = Sheets(sheetName) On Error GoTo 0 If dict Is Nothing Then MsgBox "غير موجودة" & " " & sheetName & " : " & "الصفحة", vbExclamation Check = False Else Check = True End If End Function مبيعات ومشتريات.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته اظن ان اقتراح الاخ @عبدالله بشير عبدالله سيوفي بالغرض ولإثراء الموضوع إليك بعض الحلول الأخرى =IF(I2<>"",MAX(IF($F$2:$F24=I2,$E$2:$E24)),"") =IF(I2<>"",TEXT(AGGREGATE(14,6,$E$2:$E24/($F$2:$F24=I2),1),"DD/MM/YYYY"),"") =IF(I2<>"", XLOOKUP(I2, $F$2:$F24, $E$2:$E24, "", 0, -1), "") =IF(I2<>"", IFERROR(TEXT(AGGREGATE(14,6,$E$2:$E24/($F$2:$F24=I2),1),"DD/MM/YYYY"),"لا توجد بيانات"), "") =IF(I2<>"", MAX(FILTER($E$2:$E24, $F$2:$F24=I2)), "")

نعم اخي يمكننا تنفيد دالك بعد تعديل بعض الاجراءات على الملف وتعديل الاكواد بما يتناسب مع طلبك اولا سنقوم بتغيير طريقة تعبئة القوائم المنسدلة تفاديا للاخطاء وحدف الاكواد الموجودة على حدث ThisWorkbook Sub Add_listeDéroulante() Dim OnRng As Range, Data As Range Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim f As Worksheet: Set f = Sheets("Sheet2") Set OnRng = WS.Range("B15:B24") Set Data = f.Range(f.Range("P4"), f.Range("P" & f.Rows.Count).End(xlUp)) With OnRng.Validation .Delete .Add Type:=xlValidateList, Formula1:="='" & f.Name & "'!" & Data.Address .InCellDropdown = True .ShowError = True End With End Sub في حدث Sheet2 Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Columns("B")) Is Nothing Then Application.ScreenUpdating = False Application.EnableEvents = False Dim tmp As Object Set tmp = CreateObject("Scripting.Dictionary") Dim n As Range For Each n In Range("B4", [B65000].End(xlUp)) If n.Value <> "" Then tmp(n.Value) = "" Next n With Range("P4:P65000") .ClearContents .Resize(tmp.Count) = Application.Transpose(tmp.Keys) End With Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub كود حفظ الفاتورة PDF داخل مجلد في نفس مسار الملف Sub Print_the_invoice() Dim s As Range, cell As Range Dim i As Long, r As Long, arr As Variant Dim Num_Inv As String, Client As String Dim n As String, Cnt As String, xDate As String Dim dossier As String, xPath As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") Set ligne = WS.[B15:E15] xDate = WS.[E13].Value Client = WS.[B11].Value Num_Inv = WS.[E11].Value arr = Array(Client, Num_Inv, xDate) For i = 0 To UBound(arr) If IsEmpty(arr(i)) Or arr(i) = "" Then n = "يرجى ملء بيانات " & Choose(i + 1, "إسم العميل", "رقم الفاتورة", "تاريخ الفاتورة") MsgBox n, vbExclamation, "تنبيه" Exit Sub End If If i = 1 And Not IsNumeric(arr(i)) Then MsgBox "يرجى التحقق من رقم الفاتورة", vbExclamation, "تنبيه" Exit Sub End If Next i For Each cell In ligne If IsEmpty(cell.Value) Then MsgBox "المرجوا التحقق من بيانات الفاتورة", vbExclamation: Exit Sub Next cell Cnt = WS.[D11].Value & " : " & Num_Inv & " " & _ WS.[A11].Value & " : " & Client & " " & vbCrLf & vbCrLf & _ WS.[A25].Value & " : " & Format(WS.[E25].Value, "##,0") & vbCrLf & vbCrLf If MsgBox(Cnt & vbCrLf & "هل تريد طباعة الفاتورة؟", vbYesNo + vbQuestion, "تأكيد طباعة الفاتورة") = vbNo Then Exit Sub End If Application.ScreenUpdating = False dossier = ThisWorkbook.Path & "\Invoices" If Dir(dossier, vbDirectory) = "" Then MkDir dossier End If xPath = dossier & "\" & Client & ".pdf" With WS Rows(15 & ":" & 24).EntireRow.Hidden = False For i = 15 To 24 If Cells(i, "B") = "" Then Rows(i).Hidden = True Next i .PageSetup.PrintArea = "A1:E35" .ExportAsFixedFormat Type:=xlTypePDF, Filename:=xPath Rows(15 & ":" & 24).EntireRow.Hidden = False End With r = CLng(Num_Inv) r = r + 1 WS.[E11].Value = Format(r, "00000") If MsgBox("هل تريد تفريغ بيانات الفاتورة؟", vbYesNo + vbQuestion, "تأكيد تفريغ البيانات") = vbYes Then Union(WS.Range("B11:B13"), WS.Range("E13"), WS.Range("B15:C24")).ClearContents End If Application.ScreenUpdating = True End Sub فاتورة جديدة Sub New_invoice() Dim n As Variant, t As Long, rng As Range Dim WS As Worksheet: Set WS = Sheets("Sheet1") Set rng = WS.[E15:E24] n = WS.[E11].Value If Application.WorksheetFunction.CountA(rng) = 0 Then: Exit Sub Application.ScreenUpdating = False Application.EnableEvents = False If MsgBox("فاتــورة جديدة؟", vbYesNo + vbQuestion, "تأكيد تفريغ البيانات") = vbYes Then Union(WS.Range("B11:B13"), WS.Range("E13"), WS.Range("B15:E24"), WS.Range("E25")).ClearContents If IsNumeric(n) Then t = CLng(n) t = t + 1 WS.[E11].Value = Format(t, "00000") End If End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub فاتورة مبيعات مميزه2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ربما أنت في حاجة لتوضيح طلبك أكثر أو إرفاق عينة للنتائج المتوقعة يدويا

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي لانشاء القائمة المنسدلة يمكنك اتباع الخطوات التالية لتنفيد طلبك والحصول على توسعة لنطاق البيانات بشكل ديناميكي دون الحاجة لتحديده مسبقا مع تجاهل الفراغات والقيم المكررة ضع الكود التالي في Module Sub Add_listeDéroulante() Dim lr As Long, arr() As String Dim cnt As New Collection Dim r As Range, rng As Range, i As Long Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Sheet1") Dim dest As Worksheet: Set dest = ThisWorkbook.Sheets("Sheet2") lr = dest.Cells(dest.Rows.Count, 2).End(xlUp).Row On Error Resume Next For Each r In dest.Range("B4:B" & lr) If r.Value <> "" Then cnt.Add r.Value, CStr(r.Value) End If Next r On Error GoTo 0 If cnt.Count = 0 Then: Exit Sub ReDim arr(1 To cnt.Count) For i = 1 To cnt.Count arr(i) = cnt(i) Next i Set rng = WS.Range("B15:B24") With rng.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=Join(arr, ",") .IgnoreBlank = True: .InCellDropdown = True: .ShowInput = True: .ShowError = True End With End Sub وفي حدث Sheet1 ضع الكود التالي سيتم جلب السعر عند التغيير أو الإضافة في عمود البيان وحساب القيمة عند الإدخال في عمود الكمية Private Sub Worksheet_Activate() Add_listeDéroulante End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet, data As Worksheet, result As Double Dim OnRng As Range, Search As Range, tmp As Range Dim lastRow As Long, i As Long, ColSum As Range On Error GoTo ErrorHandler Application.ScreenUpdating = False Application.EnableEvents = False Set WS = ThisWorkbook.Sheets("Sheet1") Set data = ThisWorkbook.Sheets("Sheet2") If Not Intersect(Target, WS.Range("B15:B24")) Is Nothing Then lastRow = data.Cells(data.Rows.Count, 2).End(xlUp).Row Set OnRng = data.Range("B4:B" & lastRow) For Each tmp In Intersect(Target, WS.Range("B15:B24")) If Not IsEmpty(tmp.Value) Then Set Search = OnRng.Find(What:=tmp.Value, LookIn:=xlValues, LookAt:=xlWhole) WS.Cells(tmp.Row, 4).Value = IIf(Not Search Is Nothing, Search.Offset(0, 1).Value, "") Else WS.Cells(tmp.Row, 4).Value = "" End If Next tmp End If If Not Intersect(Target, WS.Range("C15:D24")) Is Nothing Or _ Not Intersect(Target, WS.Range("B15:B24")) Is Nothing Then For i = 15 To 24 If IsNumeric(WS.Cells(i, 3).Value) And IsNumeric(WS.Cells(i, 4).Value) Then result = WS.Cells(i, 4).Value * WS.Cells(i, 3).Value WS.Cells(i, 5).Value = IIf(result <> 0, result, "") Else WS.Cells(i, 5).Value = "" End If Next i Set ColSum = WS.Range("E15:E24") If Application.WorksheetFunction.CountA(ColSum) = 0 Then WS.Range("E25").Value = "" Else WS.Range("E25").Value = Application.WorksheetFunction.Sum(ColSum) End If End If Application.EnableEvents = True Application.ScreenUpdating = True Exit Sub ErrorHandler: Application.EnableEvents = True Application.ScreenUpdating = True MsgBox "Erreur: " & Err.Description End Sub وأخيرا في حدث ThisWorkbook ضع السطور التالية لتحديث القوائم عند فتح الملف وحدفها عند الإغلاق تفاديا للأخطاء Private Sub Workbook_Open() Add_listeDéroulante End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim WS As Worksheet Set WS = ThisWorkbook.Sheets("Sheet1") WS.Range("B15:B24").Validation.Delete End Sub بالتوفيق... فاتورة مبيعات مميزه 1.xlsm

إدن هدا سوف يوفي بالغرض Sub Supp_lignes_Returns_formulas() Dim lr&, j&, i&, a, OnRng As Range Dim arr() As Variant, tmp As Variant Dim f As Worksheet: Set f = ActiveSheet lr = f.Columns("C:P").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set OnRng = f.Range("C7:P" & lr) tmp = OnRng.Value Application.ScreenUpdating = False ReDim arr(1 To UBound(tmp, 1), 1 To UBound(tmp, 2)) a = 1 For i = 1 To UBound(tmp, 1) If tmp(i, 2) <> "" And _ WorksheetFunction.CountA(Application.Index(tmp, i, 0)) > 0 Then For j = 1 To UBound(tmp, 2) arr(a, j) = tmp(i, j) Next j a = a + 1 End If Next i If a > 1 Then f.Range("C7:P" & lr).ClearContents f.Range("C7").Resize(a - 1, UBound(arr, 2)).Value = arr Else f.Range("C7:P" & lr).ClearContents End If Application.ScreenUpdating = True End Sub test002.xlsm

هناك اختلاف بين البيانات على الملف ومع طلبك الأول ماهو شرط إلغاء الصفوف الفارغة؟ الكود التالي يقوم بحذف الفراغات في حالة التحقق من وجود خلية واحدة فارغة في الأعمدة C إلى P مع الاحتفاظ بعمود التسلسل test001.xlsm

.

جرب هدا Sub Supp_lignes_Returns_formulas() Dim lastRow&, i&, j&, k&, tpm& Dim OnRng As Variant, arr As Variant, b As Boolean Dim f As Worksheet: Set f = ActiveSheet lastRow = f.Columns("B:P").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastRow < 7 Then Exit Sub Application.ScreenUpdating = False OnRng = f.Range("B4:P" & lastRow).Value tpm = 0 For i = 1 To UBound(OnRng, 1) b = True For k = 1 To UBound(OnRng, 2) If IsEmpty(OnRng(i, k)) Then b = False Exit For End If Next k If b Then tpm = tpm + 1 Next i If tpm = 0 Then Exit Sub ReDim arr(1 To tpm, 1 To UBound(OnRng, 2)) j = 0 For i = 1 To UBound(OnRng, 1) b = True For k = 1 To UBound(OnRng, 2) If IsEmpty(OnRng(i, k)) Then b = False Exit For End If Next k If b Then j = j + 1 For k = 1 To UBound(OnRng, 2) If f.Cells(i + 3, k + 1).HasFormula Then arr(j, k) = f.Cells(i + 3, k + 1).Formula Else arr(j, k) = f.Cells(i + 3, k + 1).Value End If Next k End If Next i f.Range("B7:P" & lastRow).ClearContents If tpm > 0 Then f.Range("B7").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr End If Application.ScreenUpdating = True End Sub New Microsoft Excel Worksheet v2.xlsb

بالنسبة لهده النقطة قد تم تعديلها لدمج بيانات مثلا السابعة و السابعة مهندسين في ورقة واحدة اما بخصوص البحث اظن انك بحاجة لتغيير طريقة البحث لتتمكن من فرز البيانات بجزء من قيمة البحث على جميع الأعمدة انصحك باستخدام نمودج مستخدم (يوزرفورم) سيوفر لك سرعة جلب البيانات خاصة ان ملفك الاصلي يتضمن ما يقارب 10 الف موظف الموظفين 2.xlsb

= ActiveSheet

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن اخونا الفاضل @عبدالله بشير عبدالله واثراءا للموضوع 1) تم تنفيد طلبك مع اظافة امكانية البحث على الملف عن طريق الإستعلام أو بالحروف الأولى عند تفعيل البحث التلقائي CheckBox1 2) بالنسبة لإنشاء الأوراق على نفس الملف أو مصنف جديد تمت مراعات نسخ البيانات بنفس التنسيق والترتيب 3) تفعيل خاصية البحث مع وجود حماية على ورقة الرئيسية الباسوورد 1234 أكواد البحث من خلال Textbox1 Public WS As Worksheet Public Const WsPasse As String = "1234" Sub Recherche() ' بحث بالإستعلام Dim OneRng As Range, c As Range Dim Clé As String, r As String, lastRow As Long Set WS = ThisWorkbook.Sheets("Main") WS.Unprotect Password:=WsPasse lastRow = WS.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Clé = Trim(WS.Range("B1").Value) WS.OLEObjects("CheckBox1").Object.Value = False Application.ScreenUpdating = False Set OneRng = WS.Range("A3:L" & lastRow) OneRng.Interior.ColorIndex = xlNone If Clé = "" Then MsgBox "الرجاء إدخال قيمة البحث", vbExclamation Application.ScreenUpdating = True WS.Protect Password:=WsPasse Exit Sub End If Set c = OneRng.Find(What:=Clé, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False) If Not c Is Nothing Then r = c.Address Do c.Interior.Color = RGB(255, 0, 0) Set c = OneRng.FindNext(c) Loop While Not c Is Nothing And c.Address <> r Else MsgBox "لم يتم العثور على أي نتائج", vbInformation End If WS.Protect Password:=WsPasse Application.ScreenUpdating = True End Sub '================================================== Sub Search_by_first_letters() 'بحث تلقائي Dim OneRng As Range Dim Clé As String, tmp As Variant Dim i&, j&, lastRow&, b As String Set WS = ThisWorkbook.Sheets("Main") WS.Unprotect Password:=WsPasse lastRow = WS.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set OneRng = WS.Range("A3:L" & lastRow) tmp = OneRng.Value Clé = Trim(WS.Range("B1").Value) OneRng.Interior.ColorIndex = xlNone If Clé = "" Then WS.Protect Password:=WsPasse Exit Sub End If Application.ScreenUpdating = False For i = 1 To UBound(tmp, 1) For j = 1 To UBound(tmp, 2) If Not IsEmpty(tmp(i, j)) Then b = Trim(CStr(tmp(i, j))) If Left(b, Len(Clé)) = Clé Then WS.Cells(i + 2, j).Interior.Color = RGB(255, 0, 0) End If End If Next j Next i Application.ScreenUpdating = True WS.Protect Password:=WsPasse End Sub الموظفين.xlsb

بارك الله فيك اخي @عبدالله بشير عبدالله نعم يمكننا إظافة شروط أخرى بطريقة مختصرة وبدون تقييد للمعايير فقط يكفي الإشارة على عناوين خلايا تنفيد الكود مع تعديل طريقة الفلترة لنتمكن من التحقق من وجود بيانات مطابقة قبل الانتقال لورقة لوحة المعلومات وفلترة البيانات Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rCrit As String, Lr As Long Dim OneRng As Variant, i As Long, cnt As Boolean Dim f As Worksheet: Set f = Sheets("الرئيسية") If Not Intersect(Target, Me.Range("B17, C17, D17, E17, F17, G17")) Is Nothing Then rCrit = Target.Value If rCrit = "" Then Exit Sub If f.AutoFilterMode Then f.AutoFilterMode = False Lr = f.Cells(f.Rows.count, "J").End(xlUp).Row OneRng = f.Range("J2:J" & Lr).Value For i = 1 To UBound(OneRng, 1) If OneRng(i, 1) = rCrit Then: cnt = True: Exit For Next i If cnt Then f.Activate With f.Range("B2:L" & Lr) .AutoFilter 9, rCrit End With Application.Goto f.Range("J2") Else MsgBox "قاعدة البيانات لا تتضمن معاملات من نوع " & rCrit, vbInformation, "نتيجة الفلترة" End If End If End Sub كما يمكننا كدالك استخدام مصفوفة (Array) لتحديد مجموعة من الخلايا بدلاً من تحديدها بشكل مباشر Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rCrit As String, Lr As Long, n As Boolean, ColArray As Variant Dim OneRng As Variant, i As Long, cnt As Boolean Dim f As Worksheet: Set f = Sheets("الرئيسية") ColArray = Array("B17", "C17", "D17", "E17", "F17", "G17") For i = LBound(ColArray) To UBound(ColArray) If Not Intersect(Target, Me.Range(ColArray(i))) Is Nothing Then n = True Exit For End If Next i If n Then rCrit = Target.Value If rCrit = "" Then Exit Sub If f.AutoFilterMode Then f.AutoFilterMode = False Lr = f.Cells(f.Rows.count, "J").End(xlUp).Row OneRng = f.Range("J2:J" & Lr).Value For i = 1 To UBound(OneRng, 1) If OneRng(i, 1) = rCrit Then: cnt = True: Exit For Next i If cnt Then f.Activate With f.Range("B2:L" & Lr) .AutoFilter 9, rCrit End With Application.Goto f.Range("J2") Else MsgBox "قاعدة البيانات لا تتضمن معاملات من نوع " & rCrit, vbInformation, "نتيجة الفلترة" End If End If End Sub ملف ادارة طلبات.xlsb