محمد هشام.

ممكن وضع الكود بهدا الشكل لتستطيع الفلترة باي جزء من الاسم Private Sub TextBox1_Change() Dim WS As Worksheet: Set WS = Sheet1 Set Tbl = WS.ListObjects(1) Réf = "*" & Replace(Me.TextBox1, " ", "*") & "*" Tbl.Range.AutoFilter Field:=2, Criteria1:=Réf If Me.TextBox1 = Empty Then Tbl.ShowAutoFilter = False End Sub

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

اخي سعد ببساطة لتتمكن من تنفيد المطلوب ما عليك هو وضع هده الاكواد داخل OptionButton لتنشيط ورقة العمل الهدف واستبدال اسم ورقة العمل في اكواد اليوزرفورم للتعامل دائما مع ActiveSheet Private Sub OptionButton1_Click() Sheets(CStr(OptionButton1.Caption)).Activate End sub Private Sub OptionButton2_Click() Sheets(CStr(OptionButton2.Caption)).Activate End sub Private Sub OptionButton3_Click() Sheets(CStr(OptionButton3.Caption)).Activate End sub مني 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته فقط اجعل الكود هكدا Sheets("المقبوضات").Range("A2:L2000").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("A1:D2"), CopyToRange:=Range("A4:H4"), Unique:=False وقم بجعل Criteria الخاصة بمعايير الفلترة بهدا الشكل GES1 - Copy.xlsm

اعتدر اخي @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

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

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