محمد هشام.

اعتدر اخي @husain alhammadi على التاخير في الرد بسبب ضيق الوقت على العموم كما سبق الدكر مسبقا لقد حاولت تعديل الملف ليتناسب مع متطلباتك اتمنى ان يلبي المطلوب وتستفيد منه بادن الله واي استفسار لا تتردد في دكره سوف نكون سعداء دائما بحصولك على النتيجة المطلوبة تحديد صلاحيات المستخدمين.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته قم بمراجعة الموضوع التالي ربما يفيدك

العفو اخي تفضل تم تعديل الكود واظافة انشاء مجلد الحفظ تلقائيا في نفس مسار الملف عند التحقق من عدم وجوده بالتوفيق.... Sub Copy_invoices_2() Dim j&, I&, WSdest As Workbook Dim MyData As Workbook: Set MyData = ThisWorkbook Dim Customer As String, Chemin As String, LastRow As Long Dim MyRang As Range, LastRng As Long, DesTRng As Long Dim MyFolder, Save_Folder, MyPath As String Customer = MyData.Sheets(1).[b2] On Error Resume Next If IsEmpty([b2]) Then X = MsgBox("إسم العميل غير موجود ", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "إنتباه"): Exit Sub 'اسم مجلد الحفظ قم بتعديله بما يناسبك MyFolder = "السجل" MyPath = Application.ActiveWorkbook.Path If IsEmpty(MyFolder) Then Exit Sub If IsEmpty(Customer) Then Exit Sub MkDir MyPath & "\" & MyFolder Save_Folder = MyPath & "\" & MyFolder & "\" & Customer Chemin = Save_Folder & ".xlsx" LastRow = MyData.Sheets(1).Cells(MyData.Sheets(1).Rows.Count, 1).End(xlUp).Row Set MyRang = MyData.Sheets(1).Range("A1:F" & LastRow) Application.ScreenUpdating = False Application.DisplayAlerts = False If Len(Dir(Chemin)) = 0 Then Set WSdest = Workbooks.Add MyRang.Copy With WSdest.Sheets(1).[A1] .PasteSpecial Paste:=xlPasteValuesAndNumberFormats .PasteSpecial Paste:=xlPasteFormats .PasteSpecial Paste:=xlPasteColumnWidths Sheets(1).DisplayRightToLeft = True Sheets(1).Name = Customer For j = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1 If WSdest.Sheets(1).Cells(j, 1) = "" And _ WSdest.Sheets(1).Cells(j, 5) = "0" Then Rows(j).Delete Next j End With [A1].Select WSdest.SaveAs Save_Folder & ".xlsx", FileFormat:=51 WSdest.Close Else Set WSdest = Workbooks.Open(Chemin) LastRng = WSdest.Sheets(1).Cells(WSdest.Sheets(1).Rows.Count, 1).End(xlUp).Row If WSdest.Sheets(1).[b2] <> "" Then DesTRng = LastRng + 3 Else DesTRng = LastRng + 1 MyRang.Copy With WSdest .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteFormats .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteColumnWidths Sheets(1).DisplayRightToLeft = True Sheets(1).Name = Customer End With For I = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1 If WSdest.Sheets(1).Cells(I, 1) = Empty And WSdest.Sheets(1).Cells(I, 5) = "0" Then Rows(I).Delete Next [A1].Select WSdest.SaveAs Save_Folder & ".xlsx", FileFormat:=51 WSdest.Close End If Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub الديباجة 4.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Dim f, WsData, MyRng(), Tbl() Private Sub UserForm_Initialize() Set f = Sheets("Follow up") Set WsData = f.Range("A5:I" & f.[A650000].End(xlUp).Row) MyRng = WsData.Value For i = 1 To UBound(MyRng) n = n + 1: ReDim Preserve Tbl(1 To UBound(MyRng, 2), 1 To n) For k = 1 To UBound(MyRng, 2): Tbl(k, n) = MyRng(i, k): Next k Me.ComboChoixColFiltre.List = Application.Transpose(WsData.Offset(-1).Resize(1)) Me.ComboChoixColFiltre.ListIndex = 0 Me.LabelColFiltre.Caption = "فلترة ب:" & Me.ComboChoixColFiltre ListBox1.ColumnWidths = "120;120;130;120;130;120;120;120" Next i ' لإظهار البيانات على الليست بوكس قم بتفعيل السطر التالي 'Me.ListBox1.Column = Tbl End Sub '********************************************** Private Sub CommandButton1_Click() Dim Tbl() If Recherche.Value = Empty Or ComboChoixColFiltre.Value = Empty Then MsgBox "المرجوا ادخال معيار البحث", vbInformation + vbMsgBoxRight + vbMagBoxRt1Reading, "تعليمات" Exit Sub End If colRecherche = Me.ComboChoixColFiltre.ListIndex + 1 clé = "*" & Me.Recherche & "*": n = 0 For i = 1 To UBound(MyRng) If MyRng(i, colRecherche) Like clé Then n = n + 1: ReDim Preserve Tbl(1 To UBound(MyRng, 2), 1 To n) For k = 1 To UBound(MyRng, 2): Tbl(k, n) = MyRng(i, k): Next k End If Next i If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear End Sub الإصدار أوفيسنا 2.xlsm

تفضل اخي @عمر الجزاوى Sub Copy_invoices() Dim j&, I&, WSdest As Workbook Dim MyData As Workbook: Set MyData = ThisWorkbook Dim Customer As String, Chemin As String, LastRow As Long Dim MyRang As Range, LastRng As Long, DesTRng As Long Customer = MyData.Sheets(1).[b2] Chemin = ThisWorkbook.Path & "\السجل\" & Customer & ".xlsx" LastRow = MyData.Sheets(1).Cells(MyData.Sheets(1).Rows.Count, 1).End(xlUp).Row Set MyRang = MyData.Sheets(1).Range("A1:F" & LastRow) Application.ScreenUpdating = False Application.DisplayAlerts = False If IsEmpty(Customer) Then X = MsgBox("إسم العميل غير موجود ", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "إنتباه"): Exit Sub If Len(Dir(Chemin)) = 0 Then Set WSdest = Workbooks.Add MyRang.Copy With WSdest.Sheets(1).[A1] .PasteSpecial Paste:=xlPasteValuesAndNumberFormats .PasteSpecial Paste:=xlPasteFormats .PasteSpecial Paste:=xlPasteColumnWidths Sheets(1).DisplayRightToLeft = True Sheets(1).Name = Customer For j = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1 If WSdest.Sheets(1).Cells(j, 1) = "" And _ WSdest.Sheets(1).Cells(j, 5) = "0" Then Rows(j).Delete Next j End With [A1].Select WSdest.SaveAs ThisWorkbook.Path & "\السجل\" & Customer & ".xlsx", FileFormat:=51 WSdest.Close Else Set WSdest = Workbooks.Open(Chemin) LastRng = WSdest.Sheets(1).Cells(WSdest.Sheets(1).Rows.Count, 1).End(xlUp).Row If WSdest.Sheets(1).[b2] <> "" Then DesTRng = LastRng + 3 Else DesTRng = LastRng + 1 MyRang.Copy With WSdest .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteFormats .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteColumnWidths Sheets(1).DisplayRightToLeft = True Sheets(1).Name = Customer End With For I = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1 If WSdest.Sheets(1).Cells(j, 1) = "" And _ WSdest.Sheets(1).Cells(j, 5) = "0" Then Rows(j).Delete Next [A1].Select WSdest.SaveAs ThisWorkbook.Path & "\السجل\" & Customer & ".xlsx", FileFormat:=51 WSdest.Close End If Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub الحفظ 2.rar

تمام اخي @عمر الجزاوى ممكن ارفاق ملف بشكل البيانات تحت بعض لاتمكن من تحديد النطاق لان هناك عدة صفوف فارغة بعد الترحيل هل تحتفظ بها ام نقوم بازالتها

انا بقصد ان هذا الملف فيه طلبك ممكن تضيف وتنقص أوراق العمل كما تريد بنفس الطريقة وتنقل الأكواد التي اضفتها انت اليه بكل سهولة او كان من المفروض رفع هذا الملف من قبل تفاديا لتكرار الاشتغال على الملف أكثر من مرة بالتوفيق...

نفس اليوزرفورم ونفس الطلب

وعليكم السلام ورحمة الله تعالى وبركاته هناك حل اخر ممكن ايضا جعل الكود بهده الطريقة Sub Filter_Class2() Dim WSdest As Worksheet: Set WSdest = Sheets("TI3DAD") Dim D1 As Object, D2 As Object, D3 As Object Dim i%, a As Boolean, b As Boolean, c As Boolean Dim x%, Y%, m%, z%, Réf, ky, Rng$ Set D1 = CreateObject("Scripting.Dictionary"): Set D2 = CreateObject("Scripting.Dictionary") Set D3 = CreateObject("Scripting.Dictionary") With WSdest Application.ScreenUpdating = False WSdest.Range("M4:V32,X4:AG32,AI4:AR32").ClearContents i = 7 Do While i <= .Rows.Count If WSdest.Cells(i, 2) <> "" And WSdest.Cells(i, 2) <> HasFormula Then Rng = Mid(Trim(WSdest.Cells(i, 2)), 1, 1) Select Case Rng Case "3": a = True: b = False: c = False Case "2": b = True: a = False: c = False Case Else: b = False: a = False: c = True End Select Réf = Application.Transpose(.Cells(i, 2).Resize(, 13)) Réf = Application.Transpose(Réf) If a Then D3(z) = Join(Réf, "*"): z = z + 1 ElseIf b Then D2(Y) = Join(Réf, "*"): Y = Y + 1 Else D1(x) = Join(Réf, "*"): x = x + 1 End If i = i + 1 Else Exit Do End If Loop m = 4 If D3.Count Then For Each ky In D3 WSdest.Cells(m, "M").Resize(, 13) = Split(D3(ky), "*") m = m + 1 Next ky End If m = 4 If D2.Count Then For Each ky In D2 WSdest.Cells(m, "X").Resize(, 13) = Split(D2(ky), "*") m = m + 1 Next ky End If m = 4 If D1.Count Then For Each ky In D1 WSdest.Cells(m, "AI").Resize(, 13) = Split(D1(ky), "*") m = m + 1 Next ky End If WSdest.Range("M4").CurrentRegion.Value = WSdest.Range("M4").CurrentRegion.Value WSdest.Range("X4").CurrentRegion.Value = WSdest.Range("X4").CurrentRegion.Value WSdest.Range("AI4").CurrentRegion.Value = WSdest.Range("AI4").CurrentRegion.Value End With End Sub تقرير المصلحة.xlsm

تفضل اخي سعد محمد_2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي سعد تم تنفيد دالك مع بعض التحسينات البسيطة على الاكواد Private Sub UserForm_Initialize() Dim A, B, C, D Set WSData = ActiveSheet rngData = ActiveSheet.ListObjects(1).Name A = [Tableau1]: B = [Tableau2]: C = [Tableau3]: D = [Tableau4] Colonnes = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) Tbl = Range(rngData).Value Rng = UBound(Tbl, 2) Me.ListBox2.List = Tbl Me.ListBox2.ColumnCount = Rng ListBox2.ColumnWidths = "50;65;180;80;75;75;65;80;60;35;40" Transférer Me.ListBox1.Visible = False Me.Show_file.Caption = "إظهار ملف العمل" NbLigne = [Tableau1].Rows.Count + [Tableau2].Rows.Count + [Tableau3].Rows.Count + [Tableau4].Rows.Count If Me.ComboBox1.Value = Empty Then Counter.Caption = "المجموع" & " / " & NbLigne Else Counter.Caption = Me.ComboBox1.Text & " / " & ListBox2.ListCount + 0 End Sub

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

اخي ربما ليس هناك مستحيل لاكن يتعين عليك شرح المطلوب بطريقة اوضح تقضل لقد حاولت الاشتغال على ملفك بطريقة متقدمة نوعا ما ربما تفيدك واستخراج النتائج على التيكست بوكس لكل نوع من الحركة بالاعتماد على ما فهت منك وهو عملية الجمع والطرح تكون بالشكل التالي Purchases + Sales returns - sales - Purchases returns واي استفسار او اظافة لا تتردد في دكره سوف تكون سعداء بحصولك على النتيجة المتوقعة Dim AllData(), the_range, wsdata, Target_columns(), Dates(), wsdata2, réf() Function MergeArray2DVert(A, B) maxtab1 = UBound(A) Dim tbl(): ReDim tbl(1 To UBound(A) + UBound(B), 1 To UBound(A, 2)) For I = LBound(A) To UBound(A) For C = 1 To UBound(A, 2): tbl(I, C) = A(I, C): Next Next I For I = 1 To UBound(B) For C = 1 To UBound(B, 2): tbl(maxtab1 + I, C) = B(I, C): Next Next I MergeArray2DVert = tbl End Function Private Sub UserForm_Initialize() 'دمج بيانات الجداول Dim Tablo1, Rng_1, rng2, T Tablo1 = [Tableau1]: Rng_1 = [Rng_2]: rng2 = [Rng_3]: rng3 = [Rng_4] AllData = MergeArray2DVert(Tablo1, Rng_1) AllData = MergeArray2DVert(AllData, rng2) AllData = MergeArray2DVert(AllData, rng3) the_range = "Tableau1" ' For i = 1 To UBound(AllData): AllData(i, 3) = CDate(AllData(i, 3)): Next i Me.ListBox1.ColumnCount = 8 wsdata = 8 'Target_columns = Array(1, 2, 3, 4, 6, 7, 8, 11) '(Total)في انتظار توضيح فكرة عمود Target_columns = Array(1, 2, 3, 4, 6, 7, 8) ' عمود التاريخ For I = LBound(AllData) To UBound(AllData): AllData(I, 3) = Format(AllData(I, 3), "dd/mm/yyyy"): Next I 'عمود الكمية For I = LBound(AllData) To UBound(AllData): AllData(I, 8) = Format(AllData(I, 8), "0"): Next I ' عمود Total 'For I = LBound(AllData) To UBound(AllData): AllData(I, 9) = Format(AllData(I, 9), "0.0"): Next I 'Combobox Product name Set D = CreateObject("scripting.dictionary") D("*") = "" For I = LBound(AllData) To UBound(AllData) D(AllData(I, 7)) = "" Next I réf = D.keys filtration réf, LBound(réf), UBound(réf) Me.ComboBox1.List = réf 'Combobox Invoice type Set D = CreateObject("scripting.dictionary") D("*") = "" For I = LBound(AllData) To UBound(AllData) D(AllData(I, 2)) = "" Next I réf = D.keys filtration réf, LBound(réf), UBound(réf) Me.ComboBox5.List = réf 'Combobox customer Set D = CreateObject("scripting.dictionary") D("*") = "" For I = LBound(AllData) To UBound(AllData) D(AllData(I, 4)) = "" Next I réf = D.keys filtration réf, LBound(réf), UBound(réf) Me.ComboBox4.List = réf 'combobox التاريخ Set D = CreateObject("scripting.dictionary") ligneData = 3 For I = LBound(AllData) To UBound(AllData) D(AllData(I, ligneData)) = "" Next I Dates = D.keys filtration Dates, LBound(Dates), UBound(Dates) Me.ComboBox2.List = Dates: Me.ComboBox2 = Dates(0) Me.ComboBox3.List = Dates: Me.ComboBox3 = Dates(UBound(Dates)) ComboBox1.Value = "*": ComboBox4.Value = "*": ComboBox5.Value = "*" Titles ShowAllData On Error Resume Next Me.ListBox1.ColumnWidths = "60;70;80;80;30;190;70;0" On Error GoTo 0 b_tout_Click End Sub '******************************************** Sub ShowAllData() Dim tbl() Dim F As Worksheet, B As Worksheet, S As Worksheet, D As Worksheet Set F = Sheet4: Set B = Sheet2: Set S = Sheet6: Set D = Sheet5 j = Me.ComboBox1: If j = "" Then j = "*" A = Me.ComboBox4: If A = "" Then A = "*" r = Me.ComboBox5: If r = "" Then r = "*" début = Me.ComboBox2 fin = Me.ComboBox3 ligneData = 3 ' عمود التاريخ n = 0 For I = LBound(AllData) To UBound(AllData) If AllData(I, ligneData) >= début And AllData(I, ligneData) <= fin And AllData(I, 7) Like j And AllData(I, 4) Like A And AllData(I, 2) Like r Then n = n + 1: ReDim Preserve tbl(1 To wsdata, 1 To n) C = 0 On Error Resume Next For Each k In Target_columns C = C + 1: tbl(C, n) = AllData(I, k) Next End If Next I If n > 0 Then Me.ListBox1.Column = tbl Else Me.ListBox1.Clear End If col = ListBox1.ListCount Call MH Me.Total.Value = Format(Sheet4.[Q1].Value, "0.00") TOTAL_all.Caption = "Total Quantity" & " = " & Format(Sheet4.Range("Q2").Value, "0.000") F.[O1] = "*": B.[O1] = "*": S.[O1] = "*": D.[O1] = "*" End Sub '******************************** Sub MH() Dim A As Worksheet, B As Worksheet, C As Worksheet, D As Worksheet, ws As Worksheet Dim Rng As Range For Each ws In ThisWorkbook.Worksheets Select Case ws.Name Case "Purchases", "sales", "Sales returns", "Purchase returns" Set Rng = ws.Range("O1") Rng.ClearContents Set A = Sheet4: Set B = Sheet2: Set C = Sheet6: Set D = Sheet5 If Me.ComboBox5.Value = "Purchases" And Me.ComboBox1.Value <> "*" Then A.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value 'Else A.Range("O1").Value = Empty If Me.ComboBox5.Value = "sales" And Me.ComboBox1.Value <> "*" Then B.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value ' Else B.Range("O1").Value = Empty If Me.ComboBox5.Value = "Sales returns" And Me.ComboBox1.Value <> "*" Then C.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value ' Else C.Range("O1").Value = Empty If Me.ComboBox5.Value = "Purchase returns" And Me.ComboBox1.Value <> "*" Then D.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value 'Else D.Range("O1").Value = Empty Me.Purchases.Value = Format(A.Range("P1").Value, "0.00") Me.sales.Value = Format(B.Range("P1").Value, "0.00") Me.Sales_returns.Value = Format(C.Range("P1").Value, "0.00") Me.Purchase_returns.Value = Format(D.[P1].Value, "0.00") Me.Total.Value = Format(A.[Q1].Value, "0.00") End Select Next ws End Sub sum-Listbox3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub CommandButton5_Click() Dim ws As Worksheet: Set ws = Sheets("دراسة فندق") Me.Label171.Caption = Format(ws.[F6].Text, "0,#%") 'Me.Label171.Caption = ws.Range("F6").Text 'دخل الحج Me.Label167.Caption = ws.[G6].Text 'دخل الحج Me.Label163.Caption = ws.[H6].Text 'دخل الحج Me.Label187.Caption = ws.[I6].Text 'دخل الحج Me.Label183.Caption = ws.[J6].Text 'دخل الحج Me.Label179.Caption = ws.[K6].Text 'دخل الحج Me.Label199.Caption = ws.[L6].Text 'دخل الحج Me.Label195.Caption = ws.[M6].Text 'دخل الحج Me.Label191.Caption = ws.[N6].Text 'دخل الحج 'رمضان Me.Label169.Caption = Format(ws.[F7].Text, "0,#%") 'دخل رمضان Me.Label165.Caption = ws.[G7].Text 'دخل رمضان Me.Label161.Caption = ws.[H7].Text 'دخل رمضان Me.Label185.Caption = ws.[I7].Text 'دخل رمضان Me.Label181.Caption = ws.[J7].Text 'دخل رمضان Me.Label177.Caption = ws.[K7].Text 'دخل رمضان Me.Label197.Caption = ws.[L7].Text 'دخل رمضان Me.Label193.Caption = ws.[M7].Text 'دخل رمضان Me.Label189.Caption = ws.[N7].Text 'دخل رمضان 'مواسم رمضان Label170.Caption = Format(ws.[F8].Text, "0,#%") 'دخل مواسم رمضان Label166.Caption = ws.[G8].Text 'دخل مواسم رمضان Label162.Caption = ws.[H8].Text 'دخل مواسم رمضان Label186.Caption = ws.[I8].Text 'دخل مواسم رمضان Label182.Caption = ws.[J8].Text 'دخل مواسم رمضان Label178.Caption = ws.[K8].Text 'دخل مواسم رمضان Label198.Caption = ws.[L8].Text 'دخل مواسم رمضان Label194.Caption = ws.[M8].Text 'دخل مواسم رمضان Label190.Caption = ws.[N8].Text 'دخل مواسم رمضان End Sub برنامج دراسة فندق_2.xlsm

اخي @عمر الجزاوى هدا لا علاقة له بالكود الدي قمت بارفاقه في مشاركتك الاولى . الكود كالتالي Sub حفظ() Dim fw As Variant ActiveSheet.Copy ' نسخ الشيت النشط ("b2") حفظ الملف في مجلد السجل في نفس مسار المصنف النشط وتسميته بالخلية fw = ThisWorkbook.Path & "\السجل\" & Range("b2").Value & ".xlsx" ActiveWorkbook.SaveAs fw ' حفظ الملف ActiveWorkbook.Close ' غلق المصنف الجديد End Sub اما ما تدكره حاليا هو ترحيل بيانات من ملف الى ملف اخر ليس بنسخ الشيت

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت قد فهمت طلبك بشكل صحيح .يمكنك استخدام المعادلة التالية =COUNTIFS('1'!$D$7:$D$1000;$E$10;'1'!$C$7:$C$1000;'month-allll'!D11)+COUNTIFS('2'!$D$11:$D$1000;$E$10;'2'!$C$11:$C$1000;'month-allll'!D11) او الاعتماد على تسمية النطاقات بالشكل التالي =COUNTIFS(status1;$E$10;name1;'month-allll'!D11)+COUNTIFS(status2;$E$10;name2;'month-allll'!D11) 434_formula.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب Sub حفظ() Dim myFolder As String 'خلية اسم الملف NameSh = Range("b2") ' مجلد الحفظ myFolder = ThisWorkbook.Path & "\السجل\" & NameSh If NameSh = Empty Then: MH = MsgBox("المرجوا إضافة إسم الملف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "تنبيه"): Exit Sub ActiveSheet.Copy '(VBA)' تعطيل تنبيهات Application.ScreenUpdating = False Application.DisplayAlerts = False ' تحويل الصيغ الى قيم With ActiveSheet.UsedRange .Value = .Value End With ' حدف الازرار For Each shape In ActiveSheet.Shapes shape.Delete Next ' افراغ الخلايا التي تتضمن 0 ActiveWindow.DisplayZeros = False On Error Resume Next With ActiveWorkbook .SaveAs Filename:=myFolder & ".xlsx", FileFormat:=51 ' في حالة الرغبة باظافة تاريخ اليوم ' .SaveAs Filename:=myFolder & "_" & Format(Now, "yy-mm-dd") & ".xlsx", FileFormat:=51 .Close False End With On Error GoTo 0 End Sub الحفظ.rar

السلام عليكم ورحمه الله تعالى وبركاته بعد إذن الأستاذ @أ / محمد صالح إليك حل آخر Private Sub Worksheet_Change(ByVal Target As Range) Dim WSdata As Range On Error GoTo EH Set WSdata = Me.Range("A:A") If Not Application.Intersect(WSdata, Target) Is Nothing Then Application.EnableEvents = False Select Case LCase(Target.Value) Case "done", "Done", "DONE" Me.Cells(Target.Row, 3) = Me.Cells(Target.Row, 2) Me.Cells(Target.Row, 5) = Date Case Is >= 0 Me.Cells(Target.Row, 3) = Empty Me.Cells(Target.Row, 5) = Empty End Select End If EH: Application.EnableEvents = True End Sub Test_Done.xlsb

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

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

السلام عليكم ورحمة الله تعالى وبركاته بعد ادن الاستاد الكبير @Ali Mohamed Ali تفضل اخي جرب Private Sub Worksheet_Change(ByVal Target As Range) '****************************قم بظبط الاعدادات بما يناسبك******************************** Const Première_ligne As Long = 2 ' اول صف Const PremièreColonne As String = "A" 'اول عمود Const LastColumn As String = "j" ' اخر عمود Dim R&, lastrow&, J&, Idx&, deling& Dim Sp() As String, Ky, Cols As Variant Dim dict As Object, Rng As Range, myCells As Range 'اسم الورقة الخاص بك Dim wsdata As Worksheet: Set wsdata = Worksheets("Sheet1") '(A) ' الى غاية اخر قيمة في عمود lastrow = wsdata.Cells(wsdata.Rows.Count, "A").End(xlUp).Row ' بدون تقييد 'lastrow = wsdata.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'الخلايا المتأثرة Set myCells = Intersect(Me.Range("A2:J" & lastrow), Target) If Not myCells Is Nothing Then On Error Resume Next deling = wsdata.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' نطاق البيانات Set myRng = wsdata.Range("A2:J" & deling) 'أضف العديد من الألوان كما يحلو لك Cols = Array(65535, 10086143, 16763904, 15123099, 9359529, 11854022, 32896, 65280, 16711680, 65535, 16711935, _ 16763904, 13434828, 16764057, _ 13408767, 16751052, 10079487) Application.ScreenUpdating = False Application.EnableEvents = True Set dict = CreateObject("Scripting.Dictionary") With wsdata ' حدف التنسيقات السابقة myRng.Interior.ColorIndex = 0 For J = Columns(PremièreColonne).Column To Columns(LastColumn).Column If lastrow >= Première_ligne Then Set Rng = .Range(.Cells(1, J), .Cells(lastrow, J)) Arr = Rng.Value For R = Première_ligne To lastrow If Len(Arr(R, 1)) Then dict(Arr(R, 1)) = dict(Arr(R, 1)) & "," & _ Cells(R, J).Address End If Next R End If Next J For Each Ky In dict Sp = Split(dict(Ky), ",") ' وضع شرط عدد التكرار لتنفيد الامر If UBound(Sp) > 1 Then For K = 1 To UBound(Sp) .Range(Sp(K)).Interior.Color = Cols(Idx) Next K Idx = Idx + 1 If Idx > UBound(Cols) Then Idx = LBound(Cols) End If Next Ky End With End If Application.ScreenUpdating = True End Sub Test_Couleur.xlsm

Range("AB8") = t t = "" Set fnd = .Find("Û", , , 1) v = fnd.Address If Not fnd Is Nothing Then Do t = IIf(t = "", Cells(2, fnd.Column).Text, t & "+" & Cells(2, fnd.Column).Text) Set fnd = .FindNext(fnd) Loop Until v = fnd.Address End If Range("AB10") = t End With

Sub Supprimer_tous_les_objets() For Each ws In ActiveWorkbook.Worksheets With ws On Error Resume Next ws.DrawingObjects.Delete On Error GoTo 0 End With Next End Sub

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Dim tbl As Worksheet: Set tbl = Sheet26 If Me.TextBox1 = Empty Then: Exit Sub With tbl ligne = .Cells(.Rows.Count, "c").End(xlUp).Row + 1 End With 'لمنع التكرار التحقق من الاسم والكود If Application.WorksheetFunction.CountIf(tbl.Range("c6:c" & ligne - 1), Me.TextBox1.Value) > 0 Then MsgBox "هذا الاســــــم مضاف مسبقا", vbCritical Exit Sub End If If Application.WorksheetFunction.CountIf(tbl.Range("B6:B" & ligne - 1), Me.TextBox3.Value) > 0 Then MsgBox "هذا الكــــــود مضاف مسبقا", vbCritical Exit Sub End If Dim msg As VbMsgBoxResult msg = MsgBox("ترحيل البيانات ؟ ", vbYesNo + vbQuestion + vbDefaultButton2, "تعليمات") Application.ScreenUpdating = False If msg = vbNo Then Exit Sub Else ' ترحيل البيانات tbl.Cells(ligne, 2) = Me.TextBox3.Value tbl.Cells(ligne, 4) = Me.TextBox2.Text tbl.Cells(ligne, 3) = Me.TextBox1.Text tbl.Cells(ligne, 7) = Me.ComboBox1.Text tbl.Cells(ligne, 8) = Me.ComboBox2.Text tbl.Cells(ligne, 9) = Me.ComboBox3.Text tbl.Cells(ligne, 10) = Me.TextBox4.Text tbl.Cells(ligne, 11) = Me.ComboBox4.Text tbl.Cells(ligne, 12) = Me.ComboBox5.Text tbl.Cells(ligne, 15) = Me.ComboBox9.Text tbl.Cells(ligne, 16) = Me.TextBox13.Text tbl.Cells(ligne, 19) = Me.ComboBox7.Text tbl.Cells(ligne, 26) = Me.ComboBox6.Text tbl.Cells(ligne, 13) = Format(TextBox5.Value, "yyyy/mm/dd") tbl.Cells(ligne, 14) = Format(TextBox6.Value, "yyyy/mm/dd") tbl.Cells(ligne, 20) = Me.ComboBox8.Text tbl.Cells(ligne, 22) = Me.TextBox10.Text tbl.Cells(ligne, 23) = Me.TextBox11.Text tbl.Cells(ligne, 24) = Me.TextBox12.Text tbl.Cells(ligne, 21) = Me.TextBox14.Text tbl.Cells(ligne, 25) = Me.TextBox7.Text tbl.Cells(ligne, 17) = Me.TextBox8.Value tbl.Cells(ligne, 18) = Me.TextBox9.Text If Range("C7") <> "" Then ' ترتيب tbl.Range("b6:Z" & ligne - 1).Sort Key1:=tbl.Range("C6"), Order1:=xlAscending, Header:=xlYes, DataOption1:=xlSortTextAsNumbers End If tbl.Range("a6") = 1 ' ترقيم الجدول tbl.Range("a6:a" & tbl.Range("c" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear ' اظافة المعادلات With tbl.Range("E6:E" & tbl.Range("A" & Rows.Count).End(3).Row) .Formula = "=IFERROR(DATE(LEFT(D6,1)+17&MID(D6,2,2),MID(D6,4,2),MID(D6,6,2)),"""")" ' .Value = .Value End With With tbl.Range("F6:F" & tbl.Range("A" & Rows.Count).End(3).Row) .Formula = "=IFERROR(VLOOKUP(MID(D6,8,2)*1,$AW$10:$AX$43,2,FALSE),"""")" ' .Value = .Value End With ' حدف الصفوف الفارغة من الجدول Call delete_les_lignes_vides ' افراغ B_sup_Click End If Dim msg As VbMsgBoxResult ' حدف msg = MsgBox("حدف البيانات ؟ ", vbYesNo + vbQuestion + vbDefaultButton2, "تعليمات") Application.ScreenUpdating = False If msg = vbNo Then Exit Sub Else findValue = f.Cells(N_Row, 3) With f.ListObjects("Tableau1").DataBodyRange lr = .Cells(.Rows.Count, 1).Row For I = lr To 1 Step -1 If .Cells(I, 3) = findValue Then .Rows(I).Delete f.Range("a6") = 1 f.Range("a6:a" & f.Range("c" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear UserForm_Initialize End If Next I End With End If Book V2.xlsb