محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته اليك الملف بعد التعديل على كود الاستاد @حسونة حسين واظافة جميع الاكواد الازمة محمد 4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته اليوزرفورم ينقصه عدة اكواد كالتعديل والحدف وبما انك طلبت تصحيح الاكواد الموجودة فقط قم بافراغ اليوزرفورم من الاكواد السابقة وقم بنسخ الاكواد التالية Private Sub CommandButton3_Click() ' بحث Dim sh1 As Worksheet Dim f As Range Set sh1 = Sheet54 lrw = sh1.Cells(Rows.Count, 5).End(xlUp).Row With TextBox11 If .Value = "" Then MsgBox "من فضلك ادخل الاسم الذي تريد البحث عنه يا عم سعد", vbCritical, "تنبيه يا عم سعد": Exit Sub Set f = sh1.Range("E5:E" & lrw).Find(TextBox11.Value, , xlValues, xlWhole, , , False) If Not f Is Nothing Then TextBox1.Value = sh1.Range("C" & f.Row).Value TextBox2.Value = sh1.Range("D" & f.Row).Value TextBox3.Value = sh1.Range("E" & f.Row).Value TextBox4.Value = sh1.Range("F" & f.Row).Value TextBox5.Value = sh1.Range("G" & f.Row).Value TextBox6.Value = sh1.Range("H" & f.Row).Value TextBox7.Value = sh1.Range("I" & f.Row).Value TextBox8.Value = sh1.Range("J" & f.Row).Value TextBox9.Value = sh1.Range("K" & f.Row).Value TextBox10.Value = sh1.Range("L" & f.Row).Value openpic = sh1.Range("M" & f.Row).Value Me.Image1.Picture = LoadPicture(openpic) Me.Image1.Visible = True Else MsgBox "الاسم غير موجود" End If End With End Sub '''''''''''''''''''''''''' Private Sub CommandButton2_Click() ' اظافة Dim ws As Worksheet: Set ws = Sheet54 Dim lastrow As Long lastrow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 With ws ligne = .Cells(.Rows.Count, "C").End(xlUp).Row + 1 End With ws.Cells(ligne, 4) = Me.TextBox2.Text ws.Cells(ligne, 5) = Me.TextBox3.Text ws.Cells(ligne, 6) = Me.TextBox4.Text ws.Cells(ligne, 7) = Me.TextBox5.Text ws.Cells(ligne, 8) = Me.TextBox6.Text ws.Cells(ligne, 9) = Me.TextBox7.Text ws.Cells(ligne, 10) = Me.TextBox8.Text ws.Cells(ligne, 11) = Me.TextBox9.Text ws.Cells(ligne, 12) = Me.TextBox10.Text ws.Range("C10").Value = 1 With ws.Range("C10:C" & lastrow) .Formula = "=Row() - 9" .Value = .Value End With For I = 1 To 11 Me("Textbox" & I) = "" Next I MsgBox "تم حفظ البيانات بنجاح يا عم سعد", vbInformation, "تنبيه يا عم سعد" End Sub ''''''''''''''''''''''''''''''''''''' Private Sub ListBox1_Click() Me.TextBox11.Value = Me.ListBox1.Column(0) Me.ListBox1.Visible = False End Sub Private Sub TextBox11_Change() 'الى الليست بوكس' جلب جملة البحث If Me.TextBox11.Text = "" Then Me.ListBox1.Visible = False Else Me.ListBox1.Visible = True Me.ListBox1.Clear '------------------------------ Dim lrw Set W = Sheet54 lrw = W.Cells(Rows.Count, 5).End(xlUp).Row l = 0 For Each c In Range("e10:e" & lrw) If c Like TextBox11.Text & "*" Then ListBox1.AddItem ListBox1.List(l, 0) = Cells(c.Row, 5).Value l = l + 1 End If Next c End If End Sub Private Sub TextBox11_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then TextBox11.Value = "" End If End Sub محمد (2).xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Supprimer_tous_les_objets() Dim ws As Worksheet: Set ws = Sheets("Sheet1") On Error Resume Next ws.DrawingObjects.Visible = True ws.DrawingObjects.Delete On Error GoTo 0 End Sub Book1.xls

Private Sub Workbook_Open() 'بداية عمل الكود بعد فتح الملف 'قم ببتعديل الوقت بما يناسبك Application.OnTime Now + TimeValue("00:00:10"), "ExportSpecificSheet" End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Option Explicit Sub ExportSpecificSheet() 'حدد مسار الملف Const FolderPath As String = "D:\" 'اسم الملف Const FileName As String = "نسخة من البيان الوقتى" 'حدد اسم الشيت Const SheetName As String = "Sheet2" If Evaluate("Isref('" & SheetName & "'!A1)") Then On Error Resume Next Workbooks(FileName).Close On Error GoTo 0 With ThisWorkbook Application.ScreenUpdating = False .Sheets(SheetName).Copy With ActiveWorkbook Dim ws As Worksheet: Set ws = ActiveSheet With ws.UsedRange .Value = .Value End With Application.DisplayAlerts = False .SaveAs FolderPath & FileName & " " & Format(Now, "dd-mm-yyyy hh-mm-ss") & ".xlsx" 'امتداد الملف Application.DisplayAlerts = True .Close False End With Application.ScreenUpdating = True End With MsgBox "Your's Sheet Exported Now ...", 64 End If End Sub بيان وقتى 2.xlsm

@samycalls2020 @عبدللرحيم أنا ممتن جداً لكم على تواصلكم باسمي ونيابة عن كافة الشعب المغربي ⁦‪أشكركم‬⁩ فرداً فرداً ⁦‪على‬⁩ ⁦‪تعازيكم‬⁩ ودعمكم لنا في هذا المصاب الجلل، و أقول للجميع شكر الله سعيكم وعظم أجركم وجزاكم الله عنا خير الجزاء ولا اراكم الله مكروها بأنفسكم ولا عزيز عليكم وغفر الله لأمواتنا وامواتكم ومن قال امين سائلا المولى عز وجل أن يتغمدهم بواسع الرحمة والمغفرة، وأن يلهم ذويهم الصبر والسلوان، وأن يشفي الجرحى والمصابين .

بعد ادن الاستاد الكبير @ابراهيم الحداد اليك حلول اخرى لاثراء الموضوع لا اكثر Private Sub CommandButton1_Click() Dim x, A(), i&, F&, Y&, lr&, last&, Wdata As Variant Dim WSdest As Worksheet: Set WSdest = Sheets("اعداد قوائم المدرسة") last = WSdest.Cells(Rows.Count, "a").End(xlUp).Row + 1 Application.ScreenUpdating = False WSdest.Range("A3:L" & last).ClearContents For Each Wdata In Sheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة")) lr = Wdata.Range("B" & Rows.Count).End(xlUp).Row x = Wdata.Range("B3:L" & lr) For i = 1 To UBound(x, 1) Y = Y + 1: ReDim Preserve A(1 To UBound(x, 2), 1 To Y) For F = 1 To UBound(x, 2) A(F, Y) = x(i, F) Next Next With WSdest WSdest.Range("b3").Resize(Y, UBound(A, 1)) = Application.Transpose(A) WSdest.Range("a3") = 1 WSdest.Range("a3:a" & WSdest.Range("b" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear End With Next Wdata Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub copy_data() Dim dlgR As Integer, dlgi As Integer, Wdata As Variant Dim ws As Worksheet: Set ws = Sheets("اعداد قوائم المدرسة") With ws Application.ScreenUpdating = False dlgR = .Range("A" & Rows.Count).End(xlUp).Row + 1 ws.Range("A3:l" & dlgR).ClearContents End With For Each Wdata In Sheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة")) dlgR = ws.Range("b" & Rows.Count).End(xlUp).Row With Wdata dlgi = .Range("b" & Rows.Count).End(xlUp).Row .Range("b3:l" & dlgi).Copy ws.Range("b" & dlgR + 1) ws.Range("a3") = 1 ws.Range("a3:a" & ws.Range("b" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear End With Next Application.ScreenUpdating = True End Sub اما بالنسبة ل t = Timer يمكنك الغاء الرسالة في اخر الكود فقط MsgBox Round(Timer - t, 2) قوائم المدرسة 2.xlsm

Private Sub Worksheet_Change(ByVal Target As Range) Dim A As Range, B As Range, j As Range, lr As Long lr = Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row Application.ScreenUpdating = False Set A = Range("R2:R" & lr) Set B = Range("D2:F" & lr) For Each j In Union(A, B) With j 'Modify it to suit you '.NumberFormat = "mm/dd/yyyy" .NumberFormat = "yyyy/dd/mm" End With Next j Application.ScreenUpdating = True End Sub

تفضل اخي تم تعديل الاكواد لتتناسب مع طلبك . Private Sub Worksheet_Change(ByVal Target As Range) ''''''''''''''''''''''''''' الخزينة 1 '''''''''''''''''''''''''''''''' On Error Resume Next ' 'اظافة شرط الفلترة لزر التصفية If Not Intersect(Target, Range("j3")) Is Nothing Then Add_text If Not Intersect(Target, Range("D3")) Is Nothing Then Dim LRow As Long, Réf As Range, data As Range Dim WSData As Worksheet: Set WSData = ThisWorkbook.Sheets("الخزينة1") 'اسم عمود البحث Col = WSData.Range("D3").Text 'خلية القائمة المنسدلة Set cel = [j3] Application.ScreenUpdating = False Application.Calculation = xlManual 'الغاء الفلترة WSData.ShowAllData 'نطاق البحث Set Réf = WSData.Range("D6:O6").Find(Col) If Not Réf Is Nothing Then On Error Resume Next ' افراغ البيانات السابقة WSData.Range("Ad7:Ad" & Range("Ad7").End(xlDown).Row).ClearContents LRow = WSData.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row 'نسخ العمود الهدف WSData.Range(WSData.Cells(7, Réf.Column), WSData.Cells(3325, Réf.Column)).Copy With WSData 'لصق .Range("AD7").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False 'ترتيب ابجدي (رقمي) WSData.Range("AD7:AD" & LRow).Sort Key1:=Range("AD7"), Order1:=xlAscending, Header:=xlNo 'ازالة الفراغات WSData.Range("ad7:ad" & LRow).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp 'ازالة التكرار WSData.Range("AD7", .Cells(.rows.Count, 30).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo [j3].NumberFormat = [AD7].NumberFormat End With ' اظافة قائمة منسدلة مطاطية Set data = Range(Range("Ad7"), Range("Ad" & rows.Count).End(xlUp)) With cel.validation .Delete .Add Type:=xlValidateList, Formula1:="=" & data.Address & "" [j3] = [AD7] End With End If End If [d6].Select Application.CutCopyMode = False Application.Calculation = xlAutomatic On Error GoTo 0 End Sub الخزينة6.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي قم بافراغ اليوزرفورم من جميع الاكواد واستبدالها بالاكواد التالية Private Sub TextBox1_Change() If Me.TextBox1.Text = "" Then Me.ListBox1.Visible = False For I = 2 To 5 Controls("textbox" & I).Text = "" Next I Else Me.ListBox1.Visible = True Me.ListBox1.Clear '------------------------------ Dim lrw Set W = Sheet1 lrw = W.Cells(Rows.Count, 1).End(xlUp).Row l = 0 For Each c In Range("A3:A" & lrw) If c Like TextBox1.Text & "*" Then ListBox1.AddItem ListBox1.List(l, 0) = Cells(c.Row, 1).Value l = l + 1 End If Next c End If End Sub Private Sub ListBox1_Click() Dim sh1 As Worksheet Dim f As Range Set sh1 = Sheet1 lrw = sh1.Cells(Rows.Count, 1).End(xlUp).Row Set f = sh1.Range("A3:A" & lrw).Find(ListBox1.Value, , xlValues, xlWhole, , , False) If Not f Is Nothing Then TextBox1.Value = sh1.Range("A" & f.Row).Value TextBox2.Value = sh1.Range("B" & f.Row).Value TextBox3.Value = sh1.Range("C" & f.Row).Value TextBox4.Value = sh1.Range("d" & f.Row).Value TextBox5.Value = sh1.Range("E" & f.Row).Value End If Me.ListBox1.Visible = False End Sub Private Sub UserForm_Initialize() Me.TextBox1.SetFocus End Sub Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then TextBox1.Value = "" End If End Sub سؤال مهم فى البحث للبرمجة officena 2024_2.xlsm

تفضل جرب Private Sub CommandButton1_Click() 'كود لانشاء نسخة احتياطية للملف Dim F As Workbook, J As String, Folder As String, ST As Boolean Dim B, A, ST_Path, strPath As String On Error GoTo NotAbleToSave Set F = ThisWorkbook A = "Backup" ' اسم مجلد الحفظ B = F.Name strPath = "C:\" ' تحديد مسار الحفظ Application.DisplayAlerts = False On Error Resume Next If IsEmpty(A) Then Exit Sub If IsEmpty(B) Then Exit Sub MkDir strPath & "\" & A ST_Path = strPath & "\" & A & "\" & B Folder = "C:\Backup\" ' تحديد مسار مجلد الحفظ J = F.Name ST = False If F.Path = "" Then Application.Dialogs(xlDialogSaveAs).Show Else If Dir(Folder & J) <> "" Then Kill Folder & J End If '(Save) لحفظ الملف النشط تلقائيا يمكنك تفعيل هدا السطر With F '.Save .SaveCopyAs Folder & J ST = True End With End If NotAbleToSave: Set F = Nothing If Not ST Then End If MsgBox " : تم حفظ الملف في مجلد" & vbLf & vbLf & Folder & "" & J & vbLf & "" & vbLf & vbCrLf, vbInformation + vbOKOnly, " ! تعليمات" Application.DisplayAlerts = True End Sub MMM.xlsm

تفضل For K = LBound(DestArr) To UBound(DestArr) Worksheets(DestArr(K)).Activate derligne = ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row Rng = ActiveSheet.Range("A5:N" & derligne) sours = [L2] sours2 = [D2] For i = 1 To UBound(Rng, 1) If Rng(i, 1) > 0 And Rng(i, 2) > 0 And Rng(i, 1) <> "ت" Then y = y + 1: ReDim Preserve A(1 To UBound(Rng, 2) + 2, 1 To y) For F = 1 To UBound(Rng, 2) A(F, y) = Rng(i, F) Next With ws ws.[A2].Resize(y, UBound(A, 1)) = Application.Transpose(A) A(UBound(Rng, 2) + 1, y) = sours A(UBound(Rng, 2) + 2, y) = sours2 End With End If Next Next تجميع شيتات 7.xlsm

تفضل جرب تجميع -5.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته تجميع V2 -3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب اليك 2 حلول يمكنك استخدام ما يناسبك الخزينة.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب Sub compter() Dim i& Dim sh As Worksheet: Set sh = Worksheets("ورقة1") a = [j2] b = [k2] On Error Resume Next For i = a To b If IsNumeric(b) = True And a >= 1 Then [A1] = a Application.Wait (Now + TimeValue("00:00:03")) a = a + 1 Else Exit Sub End If Next i On Error GoTo 0 End Sub

‏‏‏‏‏‏‏‏‏‏‏‏قاعدة بيانات1.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته طلبك غير واضح بالنسبة لي لاكن ربما بما ان عمود B يتضمن دائما كلمة ( رقم القائمة) في اخر صف يمكنك الاعتماد عليها لترقيم الصفحات في عمود C Sub Sequence() Dim k As Long With Sheets("الجدول") k = 1 For Réf = 4 To .Range("B" & .Rows.Count).End(xlUp).Row If .Range("B" & Réf) = "رقم القائمة" Then .Range("C" & Réf) = k k = k + 1 End If Next Réf End With End Sub ترقيم الورقة (1).xlsm

تفضل جرب Option Compare Text Dim f, Rng, wsData() Private Sub UserForm_Initialize() Set f = Sheets("التقرير") Set Rng = f.Range("A3:j" & f.[A65000].End(xlUp).Row) wsData = Rng.Value Me.ListBox1.List = wsData Me.ListBox1.ColumnCount = 10 Me.ListBox1.ColumnWidths = "120;65;65;80;80;65;80;65;80;65" Me.combobox1.List = Application.Transpose(Rng.Offset(-1).Resize(1)) Me.combobox1.ListIndex = 0 Me.LabelColFiltre.Caption = "بحث ب :" & Me.combobox1 End Sub Private Sub combobox1_click() Me.LabelColFiltre.Caption = "بحث ب: " & Me.combobox1 End Sub Private Sub TextBox1_Change() Réf_Colmun = Me.combobox1.ListIndex + 1 clé = "*" & Me.TextBox1 & "*": n = 0 Dim A() For i = 1 To UBound(wsData) If wsData(i, Réf_Colmun) Like clé Then n = n + 1: ReDim Preserve A(1 To UBound(wsData, 2), 1 To n) For k = 1 To UBound(wsData, 2): A(k, n) = wsData(i, k): Next k End If Next i If n > 0 Then Me.ListBox1.Column = A Else Me.ListBox1.Clear End Sub بحث في الفورم.xlsb

تفضل مخزون v6.xlsm

Private Sub Print_ws_Click() Dim answer As Integer, Path As String, folderName As String, WSPrinter As String Path = ThisWorkbook.Path & "\" 'اسم المجلد folderName = "ملف الكشف" & " " & Format(Now(), "yyyy-mm-dd") Set ws = Sheet2 On Error Resume Next MkDir Path & folderName Dim fileName As String ' اسم الملف المستخرج fileName = folderName & "\" & "DbSheet" & "_" & ".pdf" ws.ExportAsFixedFormat Type:=xlTypePDF, fileName:=Path & fileName MsgBox "" & Path & vbLf & vbLf & " " & _ folderName, _ vbInformation, " : تم حفظ الملف بنجاح في مجلد" Application.EnableCancelKey = xlDisabled WSPrinter = Application.ActivePrinter ws.Select answer = MsgBox(" طباعة الملف ؟", vbQuestion + vbYesNo + vbDefaultButton2, "تاكيد") If answer = vbYes Then ActiveWindow.SelectedSheets.PrintOut copies:=1, Collate:=True, ActivePrinter:="officena" Application.ActivePrinter = WSPrinter Else End If Application.EnableCancelKey = xlInterupt On Error GoTo 0 End Sub userform V3.xlsm

بحث بالاسم في تيكست بوكس.xlsm

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

اخي الملف يشتغل عندي بشكل عادي ويقوم بجلب اي بيانات موجودة في عمود CK