محمد هشام.

أستاد سعد الكود المقترح يقوم بترحيل الصفوف التي قيمتها = له دور ثان / لها دور ثان / غ كما جاء في آخر مشاركة لك هدا ما فهمت من العبارة التالية.................. بشرط ( له درو ثان و لها دور ثان و غ )في العمود 131 والملف المرفق لا يتضمن نفس الشروط (طريقة الكتابة مختلفة ) بمعنى الكود لا يتعرف على عبارة {له دور ثان في} المرجوا محاولة توضيح طلبك أكثر في المرة المقبلة لانه من الصعب مراجعة وتتبع جميع الصفوف للتحقق من تطابق طريقة كتابة كل قيمة على حدى تفضل هدا سيوفي بالغرض بادن الله باستثناء تنسيق عمود السن في أول أكتوبر Option Explicit Public Sub CopyData() '25/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' Dim arr As Long, rCrit() As String, lastRow As Long Dim Star_Row As Long, Cnt As Long, Cpt As Long Dim C As Long, Search_Row As Long, tmp As Long Dim rngA As Variant, rngB As Variant, j As String Dim WS As Worksheet: Set WS = Sheets("cheet4") Dim srcWS As Worksheet: Set srcWS = Sheets("شيت الدور الثاني صف رابع ") Cnt = 10: Star_Row = 16: Search_Row = 131 rCrit = Split("دور ثان,غ", ",") lastRow = WS.Cells(WS.Rows.Count, Search_Row).End(xlUp).Row rngA = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 28, 40, 52, 64, 76, 88, 100, 112, 116, Search_Row) rngB = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 15, 18, 21, 24, 27, 30, 33, 36, 39, 42) arr = Application.Sum _ (Application.IfError(Application.Match("*" & rCrit(Cpt) & "*", _ WS.Columns(Search_Row), 0), 0)) If arr = 0 Then: MsgBox " المرجوا التحقق من صحة المعايير ", _ vbCritical, "انتباه": Exit Sub Application.ScreenUpdating = False srcWS.Range("C10:O" & srcWS.Rows.Count).ClearContents For C = Star_Row To lastRow For Cpt = 0 To UBound(rCrit) If WS.Cells(C, _ Search_Row).Value = rCrit(Cpt) Or WS.Cells(C, _ Search_Row).Value Like "*" & rCrit(Cpt) & "*" Then For tmp = 0 To UBound(rngA) srcWS.Cells(Cnt, rngB(tmp)).Value = WS.Cells(C, rngA(tmp)).Value Next tmp Cnt = Cnt + 1 End If Next Cpt Next C Application.ScreenUpdating = True MsgBox "Done", vbInformation End Sub في حالة الرغبة بنسخ البيانات بنفس التنسيق ابلغني بدالك SAAD V2.xlsm

ادن يجب الحصول على ترابط 3 عناصر combobox 10 / 12 / 13 '**** **** A New Addition ************ Private Sub ComboBox10_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 4)) = UCase(ComboBox12.value) And _ UCase(a(i, 5)) = UCase(ComboBox13.value) Then ' قائمة عمود السعر d(a(i, 10)) = "*": ComboBox10.List = d.keys 'جلب قيمة عمود سعر التجزئة Me.TextBox7.value = a(i, 14) End If Next End Sub '**** Replacing ******** Private Sub ComboBox12_Change() ComboBox13.value = "*" ComboBox10.value = "*" Me.TextBox7.value = "*" End Sub "===Just a possibility=========== 'لجلب السعر 'If Me.ComboBox10.value <> "*" Then _ 'Me.TextBox7.value = Me.ComboBox10.value End Sub اليك الملف بعد اظافة الاكواد بيانات فاتورة2.xlsm

هل يتم نسخ البيانات بنفس التنسيق بعد كتابة الكود لاحظت انك واضع تنسيق مخصص على عمود السن في أول أكتوبر 2) هل يتم افراغ جميع الاعمدة قبل كل ترحيل جديد لان الكود السابق يقوم بافراغ الاعمدة من C الى O فقط F.Range("C10:O" & Rows.Count).ClearContents على العموم جرب هدا ووافينا بالنتيجة Option Explicit Public Sub CopyData() '24/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' Dim rCrit() As String, lastRow As Long Dim Star_Row As Long, Cnt As Long, Cpt As Long Dim C As Long, Search_Row As Long, tmp As Long Dim rngA As Variant, rngB As Variant Dim WS As Worksheet: Set WS = Sheets("cheet4") Dim srcWS As Worksheet: Set srcWS = Sheets("شيت الدور الثاني صف رابع ") Cnt = 10 Star_Row = 16 Search_Row = 131 Application.ScreenUpdating = False rCrit = Split(",لها دور ثان,له دور ثان,غ", ",") lastRow = WS.Cells(WS.Rows.Count, Search_Row).End(xlUp).Row rngA = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 28, 40, 52, 64, 76, 88, 100, 112, 116, 131) rngB = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 15, 18, 21, 24, 27, 30, 33, 36, 39, 42) srcWS.Range("C10:O" & srcWS.Rows.Count).ClearContents For C = Star_Row To lastRow For Cpt = 0 To UBound(rCrit) If WS.Cells(C, _ Search_Row).Value = rCrit(Cpt) Then For tmp = 0 To UBound(rngA) srcWS.Cells(Cnt, rngB(tmp)).Value = WS.Cells(C, rngA(tmp)).Value Next tmp Cnt = Cnt + 1 End If Next Cpt Next C Application.ScreenUpdating = True MsgBox "Done", vbInformation End Sub

اخي بما انك تريد انشاء قاعدة بيانات لتعبئة عناصر اليوزرفورم بشكل ديناميكي ومترابط اسهل طريقة بالنسبة لك هي انشاء جدول على ورقة Compte magasin يتضمن جميع الاعمدة المرغوب الاشتغال عليها مع حدف جميع الاعمدة الفارغة وتسميته مثلا ب Table1 واستبدال الاكواد الموجودة على النمودج لديك بالكود التالي شكل الملف بعد التعديل '24/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' Dim a, i As Long Dim d As Object, ComboAry As Variant Private Const Cpt As String = "Compte magasin" Private Const tbl As String = "Table1" Private Sub UserForm_Initialize() a = Sheets(Cpt).ListObjects("Table1").DataBodyRange.Columns("A:X") Set d = CreateObject("scripting.dictionary") d.CompareMode = vbTextCompare ComboAry = Array("ComboBox1", "ComboBox3", "ComboBox5", "ComboBox9", "ComboBox12") For i = 0 To UBound(ComboAry): Me.Controls(ComboAry(i)).value = "*": Next i End Sub Private Sub ComboBox1_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 2)) = "*" Next ComboBox1.List = d.keys End Sub Private Sub ComboBox2_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 2)) = UCase(ComboBox1.value) Then d(a(i, 3)) = "*" Next ComboBox2.List = d.keys End Sub Private Sub ComboBox3_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 21)) = "*" Next ComboBox3.List = d.keys End Sub Private Sub ComboBox4_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 21)) = UCase(ComboBox3.value) Then d(a(i, 22)) = "*" Next ComboBox4.List = d.keys End Sub Private Sub ComboBox5_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 23)) = "*" Next ComboBox5.List = d.keys End Sub Private Sub ComboBox11_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 23)) = UCase(ComboBox5.value) Then d(a(i, 24)) = "*" Next ComboBox11.List = d.keys End Sub Private Sub ComboBox9_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 19)) = "*" Next ComboBox9.List = d.keys End Sub Private Sub ComboBox8_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 19)) = UCase(ComboBox9.value) Then d(a(i, 18)) = "*" Next ComboBox8.List = d.keys End Sub Private Sub ComboBox12_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 4)) = "*" Next ComboBox12.List = d.keys End Sub Private Sub ComboBox13_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 4)) = UCase(ComboBox12.value) Then d(a(i, 5)) = "*" Next ComboBox13.List = d.keys End Sub '************************* Private Sub ComboBox1_Change() ComboBox2.value = "*" End Sub Private Sub ComboBox3_Change() ComboBox4.value = "*" End Sub Private Sub ComboBox5_Change() ComboBox11.value = "*" End Sub Private Sub ComboBox9_Change() ComboBox8.value = "*" End Sub Private Sub ComboBox12_Change() ComboBox13.value = "*" End Sub

ارفق ملفك اخي سعد لو سمحت

هل جربت شيء كهدا If WS.Range("DZ" & j) Like clé or WS.Range("DZ" & j) like "غ" then

وعليكم السلام ورحمة الله تعالى وبركاته ماهو اصدار الاوفيس لديك على الجهاز اخي الفاضل ؟

اليك الحلول التالية يمكنك اختيار ما يناسبك test.xlsx

السلام عليكم ورحمة الله تعالى وبركاته جرب هدا =IFERROR(INDEX(اجمالي6!$A$4:$A$600;AGGREGATE(15;6;ROW(اجمالي6!$A$1:$A$600)/(اجمالي6!$AH$4:$AH$600="ذكر")/(اجمالي6!$AE$4:$AE$600="ناجح ومنقول للصف الأول الاعدادي");ROW(اجمالي6!A1));1);"") TEST.xlsx

يسعدنا اننا استطعنا مساعدتك ادن اليك حل اخر في حالة عدم الرغبة باستخدام المعادلات Sub ExtractFromText2() Dim arr() As String, Cell As Range, i As Integer, lr& Set WS = Sheets("ATIF") Application.ScreenUpdating = False WS.Range("b2:C" & WS.Rows.Count).ClearContents lr = WS.Cells(Rows.Count, "A").End(xlUp).Row For Each Cell In Range("A2:A" & lr) arr = Split(Trim(Cell), "-") If UBound(arr) <> 0 Then For i = 0 To UBound(arr) Cell.Offset(, i + 1) = arr(i) Next End If Next Application.ScreenUpdating = True End Sub '*********OR*********** Sub ExtractFromText3() Dim r As Range, lr& Set WS = Sheets("ATIF") Application.ScreenUpdating = False With WS .Range("B2:C" & .Rows.Count).ClearContents lr = .Cells(Rows.Count, "A").End(xlUp).Row For Each r In Range("A2:A" & lr) .Range(r.Offset(0, 1), r.Offset(0, 2)).Value = Split(r, "-") Next r End With Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته هل هدا ما تقصده Sub Macro1() Msg = MsgBox("تفريغ البيانات ؟", vbYesNo, "تأكيد") If Msg <> vbYes Then Exit Sub Application.ScreenUpdating = False [D5:K18].ClearContents Application.ScreenUpdating = True End Sub

بما انني غير متاكد من مكان وضع النتائج اليك اسهل طريقة لتتمكن من تعديلها على حسب احتياجاتك Sub ExtractFromText() Dim lr& Set ws = Sheets("ATIF") Application.ScreenUpdating = False ws.Range("b2:c" & ws.Rows.Count).ClearContents lr = ws.Cells(Rows.Count, "A").End(xlUp).Row With ws.Range("B2:B" & lr) .Formula = "=LEFT(A2,FIND(""-"",A2)-1)" .Value = .Value With ws.Range("C2:C" & lr) .Formula = "=MID(A2,FIND(""-"",A2)+1,LEN(A2))" .Value = .Value End With End With Application.ScreenUpdating = True End Sub

ادن يمكنك استخدام الصيغ على النحو التالي ' الوصف =LEFT(A2,SEARCH("-",A2)-1) 'or =LEFT(A2,FIND("-",A2)-1) 'الكود =MID(A2,FIND("-",A2)+1,LEN(A2)) 'or =RIGHT(A2,LEN(A2)-SEARCH("-",A2)) 'or =MID(A2,FIND("-",A2)+1,100) مع سحب المعادلة للاسفل atf v2.xlsb

هل هده هي النتيجة المتوقعة

صراحة لم استوعب الفكرة جيدا حاول تجربة هدا يدويا وتعديله بما يناسبك Sub InsertHyperlinks() Dim a As Range, b As Range Dim rCnt As Worksheet, xCnt As Worksheet Dim WS As Worksheet, dest As Worksheet Set WS = Sheet1: Set dest = Sheet2 On Error Resume Next WS.Activate Set a = Application.InputBox("الرجاء تحديد الخلية الأولى التي تحتوي على الارتباط التشعبي" & vbCrLf & vbCrLf & _ "NOTE: يمكن إضافة الارتباطات التشعبية فقط على النص وليس على الخلايا التي تحتوي على صيغ!" & "تحديد الارتباط التشعبي 1", Type:=8) Set rCnt = a.Worksheet dest.Activate Set b = Application.InputBox("الرجاء تحديد الخلية الثانية التي تحتوي على ارتباط تشعبي" & "تحديد الارتباط التشعبي 2", Type:=8) Set xCnt = b.Worksheet WS.Hyperlinks.Add Anchor:=a, Address:="", SubAddress:= _ "'" & xCnt.Name & "'" & "!" & b.Address, TextToDisplay:=CStr(b.Value) dest.Hyperlinks.Add Anchor:=b, Address:="", SubAddress:= _ "'" & rCnt.Name & "'" & "!" & a.Address, TextToDisplay:=CStr(b.Value) End Sub

تفاديا للاخطاء لا تنسى تغديل السطر الخاص بافراغ البيانات السابقة الى f.Range("D11:R" & f.Rows.Count).ClearContents

يسعدنا اننا استطعنا مساعدتك

اخي الكريم المسالة سهلة يكفي تحديد العمود المرغوب نسخ بياناته في السطر الاول مع تحديد خلية بداية اللصق في السطر الثاني ' Sheets("نتيجةت4")اسماء الاعمدة المرغوب ترحيلها OneRng = Array("F13:F" & a, "H13:H" & a, "J13:J" & a, "l13:l" & a, "N13:N" & a, "P13:P" & a, _ "R13:R" & a, "U13:U" & a, "W13:W" & a, "Y13:Y" & a, "AA13:AA" & a, "AC13:AC" & a, "AE13:AE" & a, _ "A13:A" & a) '<=======عمود المسلسل======== ' خلية اللصق Sheets("نتيجة تقييم41") arr = Array("E11", "F11", "G11", "H11", "I11", "J11", "K11", "L11", "M11", "N11", "O11", "P11", "Q11", _ "D11")'<=====اول خلية على عمود تاريخ الميلاد======== تحويل الى كود V3.xlsm

يمكنك اظافة اسم ورقة العمل داخل الكود بهدا الشكل Private Sub CommandButton1_Click() Dim sh As Worksheet Set sh = Sheets("Sheet1") Sum = Evaluate("=SUMIFS(" & sh.Name & "!F3:F100000," & _ sh.Name & "!B3:B100000,"">=""&" & sh.Name & "!I2,B3:B100000,""<=""&" & sh.Name & "!j2)") Me.TextBox1.Value = Format(Sum, "#,##0.0") End Sub او الاعتماد على مربع Combobox لاختيار ورقة العمل المرغوب تنفيد الكود عليها Private Sub UserForm_Initialize() For Each s In ActiveWorkbook.Sheets Me.ComboBox1.AddItem s.Name Next s End Sub '******************** Private Sub CommandButton1_Click() If Me.ComboBox1 <> "" Then X = Me.ComboBox1.Value Set n = ThisWorkbook.Sheets(X) Sum = Evaluate("=SUMIFS(" & n.Name & "!F3:F100000," & n.Name & "!B3:B100000,"">=""&" & n.Name & _ "!I2,B3:B100000,""<=""&" & n.Name & "!j2)") Me.TextBox1.Value = Format(Sum, "#,##0.0") End If End Sub sumif v2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي الكريم Option Explicit Sub Découpe_45() Dim WS As Worksheet, WS2 As Worksheet Dim i As Long, j As Long, k As Long, x As Long Dim Cpt As Long, r As Long, headers As Range Set WS = ThisWorkbook.Sheets("ورقة1"): Set WS2 = ThisWorkbook.Sheets("ورقة3") Application.ScreenUpdating = False With WS2.Range("A4:F" & WS2.Rows.Count) .Cells.ClearFormats: .Cells.ClearContents End With j = 5: Cpt = 45: Set headers = WS.[A4:F4] k = WS.Range("A:F").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row For i = j To k Step Cpt If i = j Then headers.Copy Destination:=WS2.[A4] WS.Range("A" & i & ":F" & i + Cpt - 1).Copy Destination:=WS2.Range("A" & j) Else x = WS2.Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 7 headers.Copy Destination:=WS2.Range("A" & x) WS.Range("A" & i & ":F" & i + Cpt - 1).Copy Destination:=WS2.Range("A" & x + 1) End If Next i For r = 1 To 6 WS2.Cells.EntireRow.AutoFit WS2.Columns(r).ColumnWidth = WS.Columns(r).ColumnWidth Application.ErrorCheckingOptions.NumberAsText = False Next Application.ScreenUpdating = True End Sub جدول 2024.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا الحل ربما يناسبك Sub CopyRanges() Dim i As Long, a As Long, lr As Long Dim OneRng As Variant, arr As Variant, Irow As Long, C As Long Dim oldData() As Variant, newData() As Variant Dim xlnCalcMethod As XlCalculation Dim WS As Worksheet: Set WS = Sheets("نتيجةت4") Dim f As Worksheet: Set f = Sheets("نتيجة تقييم41") Irow = f.Cells.SpecialCells(xlCellTypeLastCell).Row oldData = Array("غ", "ازرق", "اخضر", "اصفر", "احمر") newData = Array("لم يتقن المعارف", "يفوق التوقعات", "امتلك المعارف والمهارات", "يحتاج لبعض الدعم", "لم يتقن المعارف") a = WS.Columns("E:AE").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row With Application xlnCalcMethod = .Calculation .Calculation = xlCalculationManual .EnableEvents = False .ScreenUpdating = False f.Range("E11:R" & f.Rows.Count).ClearContents OneRng = Array("F13:F" & a, "H13:H" & a, "J13:J" & a, "l13:l" & a, "N13:N" & a, "P13:P" & a, _ "R13:R" & a, "U13:U" & a, "W13:W" & a, "Y13:Y" & a, "AA13:AA" & a, "AC13:AC" & a, "AE13:AE" & a) arr = Array("E11", "F11", "G11", "H11", "I11", "J11", "K11", "L11", "M11", "N11", "O11", "P11", "Q11") For i = 0 To UBound(OneRng) WS.Range(OneRng(i)).Copy f.Range(arr(i)).PasteSpecial xlPasteValues Application.CutCopyMode = False Next lr = f.Columns("E:Q").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set Rng = f.Range("E11:Q" & lr) For C = LBound(oldData) To UBound(oldData) Rng.Replace oldData(C), newData(C), xlWhole, , , , False, False Next With f.Range("R11:R" & lr) .Formula = "=IF(" & WS.Name & "!F13="""",""""," & WS.Name & "!AF13)" .Value = .Value End With .Calculation = xlnCalcMethod .EnableEvents = True .ScreenUpdating = True End With End Sub تحويل الى كود V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub CommandButton1_Click() Sum = Evaluate("=SUMIFS(F3:F100000,B3:B100000,"">=""&I2,B3:B100000,""<=""&j2)") Me.TextBox1.Value = Format(Sum, "#,##0.0") End Sub sumif.xlsm

لديك اخطاء في تحديد اسماء الخلايا كما في الصورة المرفقة تم تعديل الكود ليسهل التعامل معه Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet Dim Irow As Long, Clé As String, i As Long Set WS = Sheets("Sheet2"): Set F = Sheets("Sheet1"): Clé = F.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub Irow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row Set rng = WS.Range("B3:B" & Irow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then: MsgBox " الاسم غير موجود", vbExclamation, Clé: Exit Sub For i = 3 To Irow If WS.Cells(i, 2) = Clé Then ' Colmun (D) F.[D5] = WS.Cells(i, "B") F.[D7] = WS.Cells(i, "C"): F.[D9] = WS.Cells(i, "D"): F.[D11] = WS.Cells(i, "E") F.[D13] = WS.Cells(i, "F"): F.[D15] = WS.Cells(i, "G"): F.[D17] = WS.Cells(i, "H") F.[D19] = WS.Cells(i, "I"): F.[D21] = WS.Cells(i, "J"): F.[D23] = WS.Cells(i, "K") ' Colmun (G) F.[G7] = WS.Cells(i, "L"): F.[G9] = WS.Cells(i, "M"): F.[G11] = WS.Cells(i, "N") F.[G13] = WS.Cells(i, "O"): F.[G15] = WS.Cells(i, "P"): F.[G17] = WS.Cells(i, "Q") F.[G19] = WS.Cells(i, "R"): F.[G21] = WS.Cells(i, "S"): F.[G23] = WS.Cells(i, "T") ' Colmun (J) F.[J7] = WS.Cells(i, "U") F.[J9] = WS.Cells(i, "V"): F.[J11] = WS.Cells(i, "W") F.[J13] = WS.Cells(i, "X"): F.[J15] = WS.Cells(i, "Y") End If Next Application.ScreenUpdating = True End Sub مع تعديل كود الترحيل بالشكل التالي Private Sub CommandButton1_Click() ' اظافة Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 24).Value = Application.Index(WS.Range _ ("D5,D7,D9,D11,D13,D15,D17,D19,D21,D23,G7,G9,G11,G13,G15,G17,G19,G21,G23,J7,J9,J11,J13,J15"), _ 1, 1, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A3:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With Lr = F.Range("A65500").End(xlUp).Row b = F.Cells(2, F.Columns.Count).End(xlToLeft).Column F.Range(F.Cells(3, 1), F.Cells(Lr, b)).Borders.Weight = xlThin ' افراغ CommandButton4_Click Application.ScreenUpdating = True MsgBox "تم اضافة البيانات بنجاح" End Sub 123 (1).xlsm

هدا ملف مغاير اخي الكريم على العموم تفضل هده الاكواد الخاصة بك بعد تعديلها Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet, J As Long Dim rng As Range, LastRow As Long, Clé As String Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2"): Clé = WS.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub LastRow = F.Cells(F.Rows.Count, "B").End(xlUp).Row Set rng = F.Range("B3:B" & LastRow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then MsgBox " الاسم غير موجود", vbExclamation, Clé Else J = rng.Row WS.[D5].Value = F.Cells(J, 2).Value: WS.[D7].Value = F.Cells(J, 3).Value WS.[D9].Value = F.Cells(J, 4).Value: WS.[D11].Value = F.Cells(J, 5).Value WS.[D13].Value = F.Cells(J, 6).Value: WS.[D15].Value = F.Cells(J, 7).Value WS.[D17].Value = F.Cells(J, 8).Value: WS.[D19].Value = F.Cells(J, 9).Value WS.[D21].Value = F.Cells(J, 10).Value: WS.[D23].Value = F.Cells(J, 11).Value WS.[G7].Value = F.Cells(J, 12).Value: WS.[G9].Value = F.Cells(J, 13).Value WS.[G11].Value = F.Cells(J, 14).Value: WS.[G13].Value = F.Cells(J, 15).Value WS.[G15].Value = F.Cells(J, 16).Value: WS.[G17].Value = F.Cells(J, 17).Value WS.[G19].Value = F.Cells(J, 18).Value: WS.[G21].Value = F.Cells(J, 19).Value WS.[G23].Value = F.Cells(J, 20).Value Application.ScreenUpdating = True End If End Sub اما بالنسبة لكود التعديل يمكنك اتمامه بنفس الطريقة Private Sub CommandButton5_Click() 'تعديل Dim WS As Worksheet, WS2 As Worksheet Dim LastRow As Long, i As Long Set WS = Sheets("Sheet2"): Set WS2 = Sheets("Sheet1") LastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row For i = 3 To LastRow If WS.Range("B" & i).Value = WS2.[E3] Then WS.Range("B" & i) = WS2.Range("D5") WS.Range("C" & i) = WS2.Range("D7") WS.Range("D" & i) = WS2.Range("D9") WS.Range("E" & i) = WS2.Range("D11") WS.Range("F" & i) = WS2.Range("D13") 'اتمم الكود '''''''''''''''''''' '''''''''''''''''''' MsgBox "تم تعديل البيانات بنجاح" End If Next i Application.ScreenUpdating = True End Sub 123.xlsm

جرب هل هدا ما تقصده Sub TEST() Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("ورقة2"): Set F = Sheets("ورقة3") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 26).Value = Application.Index(WS.Range _ ("D5,C7,C9,C11,D13,E15,D17,D19,D21,J7,J9,J11,J13,J15,J17,I19,K19,J21,O7,O9,O11,N13,N15,N17,O19,O21"), _ 1, 1, Array(2, 3, 1, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A4:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-3") End With Application.ScreenUpdating = True MsgBox "تم ترحيل البيانات بنجاح" End Sub New ورقة عمل Microsoft Excel 2.xlsm