محمد هشام.

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

اولا اخي الكريم معطيات غير كافية مقارنة بطلبك يجب توضيح المطلوب بدقة مع اظافة بعض الاسماء الوهمية على الملف للتجربة تفاديا لضياع الوقت لنا ولك ادن سوف انوب عنك هده المرة بشرط عدم تكرارها مرة اخرى اخي الفاضل 😄😃 ما فهمت منك انك تريد استخراج الاجمالي بشرط اسم الممول واسم الشهر الخطوات يجب تحديد اسم الورقة اولا ثم التحقق من وجود اسم الممول بها وعند العثور عليه يتم حساب مجموع الاعمدة مثلا للمبيعات على حسب المعادلة التي وضعتها =[@[مبيعات محلية 14%]]+[@[مبيعات معفية]]+[@[مبيعات جدول 5% ]]+[@[مبيعات تصدير]] و المشتريات =[@[مشتريات محلية 14%]]+[@[مشتريات معفية]]+[@[مشتريات استيراد]] لكل صف يتضمن اسم الممول الدي نريد ليتبقى لنا توضيح كيفية استخراج الرصيد من طرفك لهدا ربما ستحتاج لاستخدام الاكواد لتنفيد المطلوب وجلب النتائج المتوقعة لورقة الرئيسية هل هناك مانع لاستخدام الاكواد اخي الكريم ادا كنت قد وفقت في فهم مطلبك ووافقت على استخدام vba سوف احاول كتابة الكود المناسب لهدا الدي سيمكنك ان شاء الله من الحصول على نتائج ادق سواءا بالشهر او السنة كلها فقط لا تبخل علينا بشرح المطلوب جيدا 🤔 بالتوفيق ........... ادا وافقت يمكنني كتابة الكود المناسب

سوف احاول فقط تنظيم بعض الاكواد على حسب فهمي لها حاليا قم بتجربتها واخبرني بالنتيجة 1) Private Sub UserForm_Initialize() Dim f As Worksheet Dim OneRng As Variant Dim rng As Integer Dim d As Object Dim rw As Variant Dim i As Integer Dim lastRow As Long Dim ws As Worksheet Dim x As Variant Dim temp As Variant Dim rCrit1 As Integer, rCrit2 As Integer, rCrit3 As Integer Set f = Sheets("Inventaire") OneRng = f.Range("A2:G" & f.Cells(f.Rows.Count, 1).End(xlUp).Row).Value rng = UBound(OneRng, 2) ' ComboBox5 rCrit1 = 1 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit1)) = "" Next i rw = d.Keys tri rw, LBound(rw), UBound(rw) Me.ComboBox5.List = rw Me.ComboBox5.ListIndex = 0 ' ComboBox3 rCrit2 = 3 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit2)) = "" Next i rw = d.Keys Me.ComboBox3.List = rw Me.ComboBox3.ListIndex = 0 OneRng = f.Range("B2:G" & f.Cells(f.Rows.Count, 2).End(xlUp).Row).Value ' ComboBox1 rCrit3 = 1 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit3)) = "" Next i rw = d.Keys tri rw, LBound(rw), UBound(rw) Me.ComboBox1.List = rw Me.ComboBox1.ListIndex = 0 ' إعداد ComboBox3 rCrit2 = 2 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit2)) = "" Next i rw = d.Keys Me.ComboBox3.List = rw Me.ComboBox3.ListIndex = 0 ' إعداد TextBox5 و TextBox2 Set ws = Sheets("Log") Me.TextBox5.Value = Format(Date, "dd/mm/yyyy") lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row Me.TextBox2.Value = Format(Val(ws.Cells(lastRow, 1)) + 1, "00 00") ' إعداد ComboBox4 من العمود D Set ws = Sheets("Inventaire") lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row ComboBox4.Clear For i = 2 To lastRow If ws.Cells(i, "D").Value <> ws.Cells(i - 1, "D").Value Then ComboBox4.AddItem ws.Cells(i, "D").Value End If Next i ' فرز ComboBox4 (تصاعدي) ComboBox4.ListIndex = -1 ' إعادة تعيين الاختيار For i = 0 To ComboBox4.ListCount - 2 For j = i + 1 To ComboBox4.ListCount - 1 If ComboBox4.List(i) > ComboBox4.List(j) Then temp = ComboBox4.List(i) ComboBox4.List(i) = ComboBox4.List(j) ComboBox4.List(j) = temp End If Next j Next i Me.ComboBox5.Value = "*" CancelOperation = False End Sub بطرقة اخرى بعد فصل الكود المسؤول عن الفرز في دالة مستقلة SortArray و SortComboBox. Private Sub UserForm_Initialize() Dim f As Worksheet Dim OneRng As Variant Dim rng As Long Dim d As Object Dim rw As Variant Dim i As Long Dim rCrit1 As Long, rCrit2 As Long, rCrit3 As Long Dim lastRow As Long Dim ws As Worksheet Dim temp As String Dim j As Long ' إعداد ورقة العمل وتحديد النطاق Set f = Sheets("Inventaire") OneRng = f.Range("A2:G" & f.Cells(f.Rows.Count, "A").End(xlUp).Row).Value rng = UBound(OneRng, 2) 'غير مستخدم على ما اعتقد ' For i = 1 To UBound(OneRng): OneRng(i, 3) = OneRng(i, 3): Next i ' ComboBox5 rCrit1 = 1 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit1)) = "" Next i rw = d.Keys ' ترتيب ComboBox5 حسب العمود "اسم المخزن" (5) Call SortArray(rw) Me.ComboBox5.List = rw Me.ComboBox5.ListIndex = 0 ' ComboBox3 rCrit2 = 3 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit2)) = "" Next i rw = d.Keys Me.ComboBox3.List = rw Me.ComboBox3.ListIndex = 0 ' ComboBox1 OneRng = f.Range("B2:G" & f.Cells(f.Rows.Count, "B").End(xlUp).Row).Value rCrit3 = 1 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit3)) = "" Next i rw = d.Keys ' ترتيب ComboBox1 حسب العمود "اسم المخزن" (5) Call SortArray(rw) Me.ComboBox1.List = rw Me.ComboBox1.ListIndex = 0 ' ComboBox3 rCrit2 = 2 Set d = CreateObject("Scripting.Dictionary") d("*") = "" For i = LBound(OneRng) To UBound(OneRng) d(OneRng(i, rCrit2)) = "" Next i rw = d.Keys Me.ComboBox3.List = rw Me.ComboBox3.ListIndex = 0 ' إعداد تاريخ اليوم Set ws = Sheets("Log") Me.TextBox5.Value = Format(Date, "dd/mm/yyyy") ' إعداد رقم الطلب Dim lr As Long lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row TextBox2.Value = Format(Val(ws.Cells(lr, 1)) + 1, "00 00") ' تعبئة ComboBox4 بالقيم الفريدة من العمود D Set ws = Sheets("Inventaire") lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row For i = 2 To lastRow If ws.Cells(i, "D").Value <> ws.Cells(i - 1, "D").Value Then ComboBox4.AddItem ws.Cells(i, "D").Value End If Next i ' فرز ComboBox4 (تصاعدي) Call SortComboBox(ComboBox4) ' تعيين قيمة افتراضية لـ ComboBox5 Me.ComboBox5.Value = "*" CancelOperation = False End Sub '**************************** Private Sub SortArray(ByRef arr As Variant) Dim i As Long, j As Long Dim temp As Variant For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If arr(i) > arr(j) Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Next j Next i End Sub '************ Private Sub SortComboBox(ByRef cb As MSForms.ComboBox) Dim i As Long, j As Long Dim temp As String For i = 0 To cb.ListCount - 2 For j = i + 1 To cb.ListCount - 1 If cb.List(i) > cb.List(j) Then temp = cb.List(i) cb.List(i) = cb.List(j) cb.List(j) = temp End If Next j Next i End Sub Private Sub Search_Click() Dim ws As Worksheet Dim lastRow As Long Dim searchValue As String Dim x As Variant Dim i As Integer ' التحقق من وجود ورقة العمل On Error Resume Next Set ws = ThisWorkbook.Sheets("Transferts") On Error GoTo 0 If ws Is Nothing Then MsgBox " غير موجودة" & " " & "Transferts" & " ورقة العمل", vbCritical, "خطأ" Exit Sub End If lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row searchValue = TextBox2.Value ' مسح القوائم واستخدام حلقة For لتفريغ العناصر Dim controls As Variant controls = Array(ListBox1, ComboBox5, ComboBox2, ComboBox6, ComboBox3, ComboBox4, TextBox1) For i = LBound(controls) To UBound(controls) If TypeOf controls(i) Is MSForms.ListBox Then controls(i).Clear ElseIf TypeOf controls(i) Is MSForms.ComboBox Then controls(i).Clear ElseIf TypeOf controls(i) Is MSForms.TextBox Then controls(i).Value = "" End If Next i searchValue = TextBox2.Value x = Application.Match(Val(searchValue), ws.Columns(1), 0) If Not IsError(x) Then TextBox5.Value = ws.Cells(x, 2).Value ' عرض التاريخ ComboBox5.Value = ws.Cells(x, 4).Text ' عرض كود المخزن المحول منه ComboBox1.Value = ws.Cells(x, 5).Text ' عرض اسم المخزن المحول منه ComboBox6.Value = ws.Cells(x, 6).Text ' عرض كود المخزن المحول اليه ComboBox2.Value = ws.Cells(x, 7).Text ' عرض اسم المخزن المحول اليه Me.ListBox1.AddItem ws.Cells(x, 8) ' عرض كود الصنف Me.ListBox1.List(ListBox1.ListCount - 1, 1) = ws.Cells(x, 9) ' عرض اسم الصنف Me.ListBox1.List(ListBox1.ListCount - 1, 2) = ws.Cells(x, 10) ' عرض الكمية End If Me.ListBox1.ColumnCount = 4 Me.ListBox1.ColumnWidths = "130;130;55" End Sub Private Sub CommandButton2_Click() '''''تعديل البيانات على الليست بوكس''''' ' التحقق من وجود ورقة العمل "Transferts" If Not WorksheetExists("Transferts") Then MsgBox " غير موجودة" & " " & "Transferts" & " ورقة العمل", vbCritical, "خطأ" Exit Sub End If ' التحقق من القيم الفارغة If ListBox1.ListIndex = -1 Or (ComboBox3.Value = "" And Me.TextBox1.Value = "") Then Exit Sub If ListBox1.ListIndex <> -1 Then ' التحقق من صحة البيانات If Not IsNumeric(TextBox1.Value) Then MsgBox "الكمية يجب أن تكون رقمًا." Exit Sub End If If ComboBox1.ListIndex = -1 Then MsgBox "يرجى اختيار المخزن الذي سيتم النقل منه." Exit Sub End If Dim wsSales As Worksheet, wsStock As Worksheet Dim lastRowSales As Long, lastRowStock As Long Dim i As Long, j As Long Dim invoiceNo As Long, fromStore As String, toStore As String Dim fromStore1 As Long, toStore2 As Long Dim itemCode As String, quantity As Long, newQuantity As Long Dim quantityDiff As Long invoiceNo = Val(TextBox2.Value) fromStore = ComboBox1.Value toStore = ComboBox2.Value fromStore1 = Val(stocktr.Value) toStore2 = Val(stocktrr.Value) Set wsSales = Worksheets("Transferts") Set wsStock = Worksheets("Inventaire") lastRowSales = wsSales.Cells(wsSales.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRowSales If wsSales.Cells(i, "A").Value = invoiceNo Then newQuantity = Val(TextBox1.Value) quantity = wsSales.Cells(i, "J").Value quantityDiff = newQuantity + quantity wsSales.Cells(i, "J").Value = newQuantity wsSales.Cells(i, "M").Value = Now() ' تاريخ التعديل wsSales.Cells(i, "N").Value = Environ("Username") ' اسم المستخدم End If Next i lastRowStock = wsStock.Cells(wsStock.Rows.Count, "A").End(xlUp).Row For j = 2 To lastRowStock quantity = wsStock.Cells(j, "G").Value If wsStock.Cells(j, "B").Value = fromStore Then wsStock.Cells(j, "G").Value = newQuantity + fromStore1 ElseIf wsStock.Cells(j, "B").Value = toStore Then wsStock.Cells(j, "G").Value = toStore2 - newQuantity ' تم التعديل هنا wsStock.Cells(j, "M").Value = Now() ' تاريخ التعديل wsStock.Cells(j, "N").Value = Environ("Username") ' اسم المستخدم End If Next j MsgBox "تم تعديل الفاتورة وإرجاع الكميات بنجاح" Else MsgBox "المرجوا تحديد الصف المراد تعديله", vbCritical, "" End If End Sub '********** 'Transferts دالة للتحقق من وجود ورقة العمل Function WorksheetExists(sheetName As String) As Boolean Dim ws As Worksheet On Error Resume Next Set ws = Worksheets(sheetName) On Error GoTo 0 WorksheetExists = Not ws Is Nothing End Function

تفضل اخي تم انشاء الكود لتنفيد طلبك بادن الله يكفي الظغط علر زر إزالة العلامات الزائدة 🤔 Sub Remove_additional_Tags() Dim WS As Worksheet, i As Long, _ OneRng As Range, cell As Range, _ CntText As String, tmp As String, _ rCount As Long Set WS = ThisWorkbook.Sheets("ورقة2") Set OneRng = WS.Range("B7:B" & WS.Cells(WS.Rows.Count, "B").End(xlUp).Row) Application.ScreenUpdating = False rCount = 0 For Each cell In OneRng CntText = cell.Value tmp = "" ' ****حساب عدد العلامات الأصلية***** Dim originalPlusCount As Long, newPlusCount As Long originalPlusCount = Len(CntText) - Len(Replace(CntText, "+", "")) ' *****إزالة علامات "+" المتتالية أو غير الضرورية****** Dim src As String src = Trim(CntText) Do While InStr(src, " + +") > 0 src = Replace(src, " + +", " + ") Loop If Left(src, 2) = " + " Then src = Mid(src, 3) End If If Right(src, 2) = " + " Then src = Left(src, Len(src) - 2) End If ' ****إزالة أي علامة "+" بعد آخر كلمة***** If Right(src, 1) = "+" Then src = Left(src, Len(src) - 1) End If Dim words() As String words = Split(src, " + ") For i = LBound(words) To UBound(words) If Trim(words(i)) <> "" Then If tmp <> "" Then tmp = tmp & " + " & Trim(words(i)) Else tmp = Trim(words(i)) End If End If Next i ' ****حساب عدد العلامات التي تمت إزالتها***** newPlusCount = Len(tmp) - Len(Replace(tmp, "+", "")) rCount = rCount + (originalPlusCount - newPlusCount) cell.Value = tmp Next cell Application.ScreenUpdating = True If rCount > 0 Then MsgBox "تمت إزالة" & " " & rCount & _ " علامة غير مستخدمة بنجاح ", vbInformation Else MsgBox "لا يوجد علامات زائدة", vbInformation End If End Sub RS_ST_196 V3.xls

هذا ما كنت أحاول فهمه كما سبق الذكر يمكنك ذالك بدون الاعتماد أو إظافة الارتباط التشعبي ضع الكود التالي في حدث ورقة الرئيسية Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim f As Worksheet: Set f = ThisWorkbook.Sheets("الرئيسية") Application.ScreenUpdating = False f.Range("M2:M" & f.Rows.Count).ClearContents ' تحديث العمود "M" بالنص "تفاصيل الطلب" لكل صف يحتوي على قيمة في العمود "B" For i = 2 To f.Cells(f.Rows.Count, "B").End(xlUp).Row If f.Cells(i, "B").Value <> "" Then f.Cells(i, "M").Value = "تفاصيل الطلب" ' <<=====' يمكنك تعديل النص بما يناسبك End If Next i Application.ScreenUpdating = True If Not Intersect(Target, Me.Columns("M")) Is Nothing Then Dim lr As Long, OneRng As Range Dim rCrit As String, tmp As Boolean tmp = False On Error Resume Next tmp = Not ThisWorkbook.Sheets("التفصيلية") Is Nothing On Error GoTo 0 If Not tmp Then MsgBox "ورقة العمل التفصيلية غير موجودة", vbExclamation Exit Sub End If If Target.Row > 1 Then If Me.Cells(Target.Row, "M").Value <> "" And Me.Cells(Target.Row, "B").Value <> "" Then Dim WS As Worksheet Set WS = ThisWorkbook.Sheets("التفصيلية") If WS.AutoFilterMode Then WS.AutoFilterMode = False rCrit = Me.Cells(Target.Row, "B").Value If rCrit <> "" Then lr = WS.Cells(WS.Rows.Count, "J").End(xlUp).Row Set OneRng = WS.Range("J2:J" & lr).Find(What:=rCrit, LookIn:=xlValues, LookAt:=xlWhole) If Not OneRng Is Nothing Then WS.Activate With WS.Range("B2:O" & lr) .AutoFilter 9, rCrit End With Else MsgBox "غير موجود في قاعدة البيانات" & " : " & rCrit, 16 End If End If End If End If End If End Sub طلب فلتر V3.xlsb

غريب لقد أعدت تجربة الملف و الكود يشتغل بشكل جيد !! ممكن توضح لي أكثر ما تحاول فعله؟ لكي نستطيع مساعدتك هل ستقوم كل مرة بإدخال قيمة معينة في الخلية B2 وفلترة البيانات عليها؟ بعد معاينة الملف الخاص بك أعتقد أن الطريقة الأصح أنك تقوم مثلا بإضافة عبارة (تفاصيل إظافية) على عمود M وعند الظغط عليها يتم الانتقال إلى ورقة التفضيلية وفلترة الجدول بشرط القيمة المقابلة في عمود b وهذا يمكنك فعله بدون إظافة اي ارتباطات تشعبية فقط بالاكواد

نعم لاكننا قمنا بتغيير إسمه تفاديا لاظافة اي أكواد جديدة وبما اننا نتوفر على عنصر واحد فقط وله نفس الدور فلا حاجة لذالك يمكنك إدراجه ضمن تسلسل عناصر التكست ليشتغل دينامكيا مع أكواد ( الترحيل و التعديل )

أخي لقد تمت إظافة الأكواد مسبقا للملف المرفق

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

هل تقصد أنك تريد إزالة علامات [+] الزائدة في نفس مكان للبيانات الأصلي؟ ربما تحتاج إلى استخدام الأكواد لتنفيذ طلبك

RS_ST_196.xls

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub CreateHyperlink() Dim targetCell As Range, Clé As String Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("الرئيسية") Dim f As Worksheet: Set f = ThisWorkbook.Sheets("التفصيلية") Dim lastRow As Long Clé = WS.Range("B2").Value Set targetCell = WS.Range("M2") WS.Hyperlinks.Add Anchor:=targetCell, Address:="", SubAddress:= _ "التفصيلية!A1", TextToDisplay:="تفاصيل الطلب" If Clé <> "" Then f.Activate If f.AutoFilterMode Then f.AutoFilterMode = False lastRow = f.Cells(f.Rows.Count, "J").End(xlUp).Row f.Range("J2:J" & lastRow).AutoFilter Field:=1, Criteria1:=Clé End If End Sub وفي حدث ورقة الرئيسية Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink) On Error Resume Next If Target.Range.Address = "$M$2" Then Call CreateHyperlink End If End Sub طلب فلتر.xlsb

لم استوعب طلبك جيدا لاكن جرب شيء كهدا =TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(B7, " + ", " "), " +", ""), "+ ", "")) او =TRIM(SUBSTITUTE(TEXTJOIN(" + ", TRUE, FILTER(TEXTSPLIT(B7, " + "), TEXTSPLIT(B7, " + ") <> "")), " + +", " +"))

للأسف، في VBA و MSForms.DataObject، لا يمكنك تنفيذ اللصق مباشرة في واجهة التطبيقات الخارجية مثل محرك جوجل أو أي تطبيق آخر من خلال كود VBA فقط. لكن، يمكنك استخدام SendKeys لمحاكاة ضغطات لوحة المفاتيح، وهي طريقة غير مضمونة تمامًا جرب هدا Private Sub CommandButton1_Click() 'SendKeys لمحاكاة الضغط على Ctrl + V (للصق) Dim objCpt As New MSForms.DataObject Dim textToCopy As String ' التحقق مما إذا كان هناك نص في TextBox1 If TextBox1.Text = "" Then MsgBox "لا يوجد محتوى للنسخ. الرجاء إدخال نص أو رقم أولاً.", vbExclamation Else ' الحصول على النص من TextBox1 textToCopy = TextBox1.Text ' وضع النص في الحافظة objCpt.SetText textToCopy objCpt.PutInClipboard ' تأكيد النسخ MsgBox "تم نسخ النص إلى الحافظة.", vbInformation ' تأخير بسيط للتأكد من أن النص تم نسخه بنجاح Application.Wait (Now + TimeValue("0:00:01")) ' محاكاة ضغطات لوحة المفاتيح للصق النص SendKeys "^v" End If End Sub إذا كنت تحتاج إلى مميزات تتطلب تفاعلًا مع واجهات أكثر تعقيدًا، فقد تحتاج إلى استخدام أدوات خارجية أو لغات برمجة أخرى توفر إمكانيات أكثر تقدمًا مثل AutoIt أو AutoHotkey. بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته اخي طريقة تصميمك للملف وكثرة الخلايا المدمجة وتنسيق عرض الصفوف ربما سوف يسبب لك عائق لظهور النتائج بشكل صحيح خاصة عند استخدام الاكواد على العموم لقد قمت بانشاء كودين لنفس المهمة واحد لاستخراج النتائج بالطريقة المطلوبة والاخر لاستخراجها على ورقة اخرى وتنسيقها يمكنك اختيار ما يناسبك Sub Collection_of_books() ' استخراج في ورقة RS_ST_196 Dim WS As Worksheet, i As Long, lr As Long Dim lastRow As Long, n As String Dim studentName As String, ling As Long Dim bookName As String Dim bookNumber As Variant Dim startRow As Long Application.ScreenUpdating = False Set WS = ThisWorkbook.Sheets("RS_ST_196") lastRow = WS.Cells(WS.Rows.Count, "AK").End(xlUp).row WS.Range("BC19:BD" & WS.Rows.Count).ClearContents ling = 19 For i = 18 To lastRow If Not WS.Rows(i).Hidden Then studentName = WS.Cells(i, "AK").Value If InStr(studentName, "اسم الطالب: ") = 1 Then studentName = Trim(Mid(studentName, Len("اسم الطالب: ") + 1)) n = "" startRow = i + 2 Do While WS.Cells(startRow, "AB").Value <> "" bookName = WS.Cells(startRow, "AB").Value bookNumber = WS.Cells(startRow, "AN").Value If WS.Cells(startRow, "AB").Value <> "اسم المقرر" And _ Not IsEmpty(bookNumber) Then If n = "" Then n = bookName Else n = n & " + " & bookName End If End If startRow = startRow + 1 Loop WS.Cells(ling, "BD").Value = studentName WS.Cells(ling, "BC").Value = n ling = ling + 1 End If End If Next i lr = WS.Cells(WS.Rows.Count, "BD").End(xlUp).row With WS.Range("BC19:BD" & lr) .MergeCells = False .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = True End With Application.ScreenUpdating = True MsgBox "تم تجميع أسماء الطلاب والكتب بنجاح", vbInformation End Sub Sub Collection_of_books_Sheet1() 'Sheet1 نسخ على ورقة Dim WS As Worksheet, dest As Worksheet Dim lastRow As Long, i As Long Dim studentName As String, bookName As String, n As String Dim bookNumber As Variant, row As Range, lr As Long Dim startRow As Long, ling As Long, bCount As Integer Dim r As Long Application.ScreenUpdating = False Set WS = ThisWorkbook.Sheets("RS_ST_196") Set dest = ThisWorkbook.Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, "AK").End(xlUp).row dest.Range("A2:C" & dest.Rows.Count).ClearContents ling = 2 For i = 18 To lastRow If Not WS.Rows(i).Hidden Then studentName = WS.Cells(i, "AK").Value If InStr(studentName, "اسم الطالب: ") = 1 Then studentName = Trim(Mid(studentName, Len("اسم الطالب: ") + 1)) n = "" bCount = 0 startRow = i + 2 Do While WS.Cells(startRow, "AB").Value <> "" bookName = WS.Cells(startRow, "AB").Value bookNumber = WS.Cells(startRow, "AN").Value If WS.Cells(startRow, "AB").Value <> "اسم المقرر" And _ Not IsEmpty(bookNumber) Then If n = "" Then n = bookName Else n = n & " + " & bookName End If bCount = bCount + 1 End If startRow = startRow + 1 Loop dest.Cells(ling, "A").Value = studentName ' اسماء الطلاب dest.Cells(ling, "B").Value = n ' تجميع الكتب dest.Cells(ling, "C").Value = bCount ' عدد الكتب لكل طالب ling = ling + 1 End If End If Next i lr = dest.Cells(dest.Rows.Count, "A").End(xlUp).row With dest.Range("A2:C" & lr) .Borders.LineStyle = xlNone .MergeCells = False .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = True r = dest.Cells(2, dest.Columns.Count).End(xlToLeft).Column Range(dest.Cells(2, 1), dest.Cells(lr, r)).Borders.Weight = xlThin For Each row In .Rows row.RowHeight = 35 Next row End With Application.ScreenUpdating = True MsgBox "تم تجميع أسماء الطلاب والكتب بنجاح", vbInformation End Sub يمكنك الغاء علامة (+) الموجودة بين الاسماء بتعديل هدا السطر n = n & " + " & bookName الى n = n & " " & bookName RS_ST_196 V2.xls

جرب هدا في جزء تسجيل التغيير في ورقة العمل Log هناك خطأ حيث يتم إدخال quantity مرتين في العمود الثامن Sub TransferQuantities() On Error GoTo ErrHandler ' تعريف المتغيرات Dim lastRow As Long Dim itemData As Object Dim i As Long Dim itemCode As String Dim quantityToTransfer As Long Dim itemName As String Dim sourceKey As String Dim targetKey As String Dim currentDate As Date Dim answer As VbMsgBoxResult Dim fa As Worksheet ' تحديد الورقة واستخدام المتغير Set fa = Sheets("Inventaire") ' تحديد آخر صف في ورقة المخزون lastRow = fa.Cells(fa.Rows.Count, "A").End(xlUp).Row ' ملء قاموس ببيانات الأصناف Set itemData = CreateObject("Scripting.Dictionary") For i = 2 To lastRow Dim key As String key = fa.Cells(i, 3).Value & "_" & fa.Cells(i, 2).Value ' مفتاح فريد: كود الصنف + اسم المخزن itemData.Add key, i ' تخزين رقم الصف المقابل للمفتاح Next i ' تأكيد عملية النقل قبل بدء التنفيذ answer = MsgBox("هل أنت متأكد من تنفيذ عملية النقل؟", vbYesNo, "تأكيد") If answer <> vbYes Then Exit Sub ' الحصول على التاريخ الحالي currentDate = Date ' التكرار على عناصر ListBox1 For i = 0 To ListBox1.ListCount - 1 itemCode = ListBox1.List(i, 0) itemName = ListBox1.List(i, 1) quantityToTransfer = Val(ListBox1.List(i, 2)) sourceKey = itemCode & "_" & Me.ComboBox1.Value targetKey = itemCode & "_" & Me.ComboBox2.Value ' التحقق من وجود الصنف في قائمة التحويل If Not IsInList(itemCode, ListBox1) Then MsgBox "الصنف " & itemCode & " غير موجود في قائمة التحويل.", vbCritical Exit Sub End If ' التحقق من صحة البيانات If quantityToTransfer <= 0 Then MsgBox "الكمية يجب أن تكون موجبة.", vbCritical Exit Sub End If ' التحقق من وجود الصنف في المخازن المصدر والهدف If Not itemData.Exists(sourceKey) Then MsgBox "الصنف " & itemCode & " غير موجود في المخزن المصدر " & Me.ComboBox1.Value, vbCritical Exit Sub End If If Not itemData.Exists(targetKey) Then MsgBox "الصنف " & itemCode & " غير موجود في المخزن الهدف " & Me.ComboBox2.Value, vbCritical Exit Sub End If ' التحقق من الكمية المتاحة في المخزن المصدر If fa.Cells(itemData(sourceKey), 7).Value < quantityToTransfer Then MsgBox "الكمية المتاحة في المخزن المصدر غير كافية.", vbCritical Exit Sub End If ' تحديث الكميات On Error GoTo HandleError fa.Cells(itemData(sourceKey), 7).Value = fa.Cells(itemData(sourceKey), 7).Value - quantityToTransfer fa.Cells(itemData(targetKey), 7).Value = fa.Cells(itemData(targetKey), 7).Value + quantityToTransfer On Error GoTo 0 ' تسجيل التغيير With Sheets("Log") lastRowLog = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 .Cells(lastRowLog, 1).Value = TextBox2.Value ' رقم الفاتورة .Cells(lastRowLog, 2).Value = TextBox5.Value ' التاريخ .Cells(lastRowLog, 3).Value = "تم تحويل " & quantityToTransfer & " من مخزن " & Me.ComboBox1.Value & " إلى مخزن " & Me.ComboBox2.Value .Cells(lastRowLog, 4).Value = Me.ComboBox1.Value .Cells(lastRowLog, 5).Value = Me.ComboBox2.Value .Cells(lastRowLog, 6).Value = itemCode .Cells(lastRowLog, 7).Value = itemName .Cells(lastRowLog, 8).Value = quantityToTransfer .Cells(lastRowLog, 9).Value = Environ("Username") End With Next i MsgBox "تمت عملية التحويل بنجاح. تم تسجيل التغييرات.", vbInformation Exit Sub ErrHandler: Dim errorLog As String errorLog = "وقت الحدوث: " & Now & vbNewLine & _ "الخطأ: " & Err.Description & vbNewLine & _ "رقم السطر: " & Erl & vbNewLine & _ "الإجراء: " & Err.Source & vbNewLine & _ "القيم: itemCode=" & itemCode & ", quantity=" & quantityToTransfer & ", sourceKey=" & sourceKey & ", targetKey=" & targetKey Open "ErrorLog.txt" For Append As #1 Print #1, errorLog Close #1 MsgBox "حدث خطأ أثناء عملية التحويل. يرجى التحقق من البيانات والمحاولة مرة أخرى.", vbCritical End Sub Private Sub UserForm_Initialize() CancelOperation = False End Sub Private Sub cmdCancel_Click() CancelOperation = True Me.Hide End Sub Function IsInList(itemValue As Variant, myList As Object) As Boolean Dim i As Long For i = 0 To myList.ListCount - 1 If myList.List(i, 0) = itemValue Then IsInList = True Exit Function End If Next i IsInList = False End Function

Sub CopyData() Dim src As Worksheet, dest As Worksheet Dim Clé As String, foundCell As Range Dim tmp As Long Dim cnt As Boolean Dim i As Integer Dim sumRange As Range Dim totalCell As Range Set src = ThisWorkbook.Sheets("ورقة1") Set dest = ThisWorkbook.Sheets("ورقة2") ' الحصول على القيمة من الخلية D3 Clé = src.Range("D3").Value ' التحقق من إدخال قيمة في الخلية D3 If Clé = "" Then MsgBox "يرجى إدخال الرقم الخاص", vbExclamation Exit Sub End If ' تحديد نطاق البحث والعثور على الخلية 'ورقة1 (D)' الى اخر خلية بها بيانات في عمود Set srcRng = src.Range("D11:D" & src.Cells(src.Rows.Count, "D").End(xlUp).Row) Set foundCell = srcRng.Find(What:=Clé, LookIn:=xlValues, LookAt:=xlWhole) ' التحقق من العثور على القيمة If Not foundCell Is Nothing Then tmp = foundCell.Row ' التحقق من وجود بيانات في الصف cnt = False For i = 7 To 18 If src.Cells(tmp, i).Value <> "" Then cnt = True Exit For End If Next i If cnt Then ' مسح محتويات عمود (J) في ورقة 2 dest.Range("J9:J" & dest.Rows.Count).ClearContents ' نسخ البيانات إلى عمود (J) For i = 7 To 18 dest.Cells(9 + (i - 7), 10).Value = src.Cells(tmp, i).Value Next i dest.[F2].Value = src.Cells(tmp, 3).Value dest.[F3].Value = Clé ' حساب مجموع القيم في العمود (J) وإدخاله في الخلية F4 و j21 Set sumRange = dest.Range("J9:J20") Set totalCell = Union(dest.Range("F4"), dest.Range("j21")) totalCell.Value = Application.WorksheetFunction.Sum(sumRange) MsgBox "تم نسخ البيانات بنجاح ", vbInformation Else MsgBox "خلايا التقييم فارغة", vbExclamation End If Else MsgBox "لم يتم العثور على الرقم الخاص", vbCritical End If End Sub تقييم v3.xlsb

ممكن توضح اكثر

هل تقصد انك تريد نفس القيم في عمود ( j )

تفضل اخي Sub CopyData() Dim src As Worksheet, f As Worksheet Dim Clé As String, foundCell As Range Dim Cnt As Long, i As Integer Dim Cpt As Boolean Set src = ThisWorkbook.Sheets("ورقة1") Set f = ThisWorkbook.Sheets("ورقة2") Clé = src.[D3].Value If src.[D3].Value = "" Then MsgBox "يرجى ادخال الرقم الخاص" Exit Sub End If Set cellRange = Union(f.Range("F4"), f.Range("D21")) Set srcRng = src.Range("D11:D" & src.Cells(src.Rows.Count, "D").End(xlUp).Row) Set foundCell = srcRng.Find(What:=Clé, LookIn:=xlValues, LookAt:=xlWhole) If Not foundCell Is Nothing Then Cnt = foundCell.Row Cpt = False For i = 7 To 18 If src.Cells(Cnt, i).Value <> "" Then Cpt = True Exit For End If Next i If Cpt Then f.Range("d9:d" & f.Rows.Count).ClearContents f.[F3].Value = Clé For i = 7 To 18 f.Cells(9 + (i - 7), 4).Value = src.Cells(Cnt, i).Value f.[F2].Value = src.Cells(Cnt, 3).Value Next i SumCol = Application.WorksheetFunction.Sum(f.Range("D9:D20")) cellRange.Value = SumCol MsgBox "تم نسخ البيانات بنجاح", 64 Else MsgBox "خلايا التقييم فارغة", 48 End If Else MsgBox "لم يتم العثور على الرقم الخاص في قاعدة البيانات", 16 End If End Sub المصنف1 v2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام شيئ كهدا Private Sub CommandButton19_Click() 'TEXTBOX1'نسخ الى الحافظة Dim objCpt As New MSForms.DataObject Dim textToCopy As String If TextBox1.Text = "" Then MsgBox "لا يوجد محتوى للنسخ. الرجاء إدخال نص أو رقم أولاً.", 64 Else ' الحصول على النص من TextBox1 textToCopy = TextBox1.Text ' وضع النص في الحافظة objCpt.SetText textToCopy objCpt.PutInClipboard ' MsgBox "تم نسخ النص إلى الحافظة.", vbInformation End If End Sub '************************** Private Sub CommandButton20_Click() Dim objCpt As New MSForms.DataObject Dim textToCopy As String ' الحصول على نص الحافظة On Error Resume Next objCpt.GetFromClipboard textToCopy = objCpt.GetText On Error GoTo 0 ' التحقق مما إذا كانت TextBox1 فارغة If Me.TextBox1.Text = "" Then MsgBox "TextBox1 فارغ. لا يمكن إجراء العملية.", vbExclamation ' التحقق مما إذا كانت الحافظة فارغة ElseIf textToCopy = "" Then MsgBox "الحافظة فارغة. يرجى نسخ نص إلى الحافظة أولاً.", vbExclamation Else ' لصق نص الحافظة إلى TextBox6 Me.TextBox6.Text = textToCopy ' MsgBox "تم لصق النص من الحافظة إلى TextBox6.", vbInformation End If End Sub ولنسخ البيانات من خارج اليوزرفورم او العكس Private Sub CommandButton2_Click() 'TEXTBOX 1 ' لصق في الخلية النشطة If Me.TextBox1.Text = "" Then MsgBox "لا يوجد محتوى للنسخ. الرجاء إدخال نص أو رقم أولاً.", 64 Exit Sub End If ' التحقق من وجود خلية نشطة If activeCell Is Nothing Then MsgBox "لا توجد خلية نشطة. يرجى تحديد خلية أولاً.", 64 Exit Sub End If ' لصق النص من TextBox1 في الخلية النشطة activeCell.Value = Me.TextBox1.Value MsgBox "تم لصق النص في الخلية النشطة.", vbInformation End Sub '***************** Private Sub CommandButton3_Click() 'TEXTBOX 6 ' لصق في الخلية النشطة If Me.TextBox6.Text = "" Then MsgBox "لا يوجد محتوى للنسخ. الرجاء إدخال نص أو رقم أولاً.", 64 Exit Sub End If ' التحقق من وجود خلية نشطة If activeCell Is Nothing Then MsgBox "لا توجد خلية نشطة. يرجى تحديد خلية أولاً.", 64 Exit Sub End If ' لصق النص من TextBox6 في الخلية النشطة activeCell.Value = Me.TextBox6.Value MsgBox "تم لصق النص في الخلية النشطة.", vbInformation End Sub '**************** Private Sub CommandButton21_Click() 'TEXTBOX 1'نسخ ولصق من الخلية النشطة ' التحقق من وجود خلية نشطة If activeCell Is Nothing Then MsgBox "لا توجد خلية نشطة. يرجى تحديد خلية أولاً.", 64 Exit Sub End If ' التحقق من كون الخلية النشطة فارغة If IsEmpty(activeCell.Value) Then MsgBox "الخلية النشطة فارغة. يرجى تحديد خلية تحتوي على بيانات.", 64 Exit Sub End If ' نقل النص من الخلية النشطة إلى TextBox6 Me.TextBox1.Value = activeCell.Value MsgBox "TextBox1" & " " & "تم نقل قيمة الخلية النشطة إلى", vbInformation End Sub '************* Private Sub CommandButton5_Click() 'TEXTBOX 6'لصق في الخلية النشطة ' التحقق من وجود خلية نشطة If activeCell Is Nothing Then MsgBox "لا توجد خلية نشطة. يرجى تحديد خلية أولاً.", 64 Exit Sub End If ' التحقق من كون الخلية النشطة فارغة If IsEmpty(activeCell.Value) Then MsgBox "الخلية النشطة فارغة. يرجى تحديد خلية تحتوي على بيانات.", 64 Exit Sub End If ' نقل النص من الخلية النشطة إلى TextBox6 Me.TextBox6.Value = activeCell.Value MsgBox "TextBox6" & " " & "تم نقل قيمة الخلية النشطة إلى", vbInformation End Sub بما ان ملفك يتضمن عدة اخطاء يجب اصلاحها حاولت فقط وضع الاكواد على Private Sub CommandButton19_Click و Private Sub CommandButton20_Click اليك ملفك مع ملف تم انشاءه لتطبيق عليه بعض الأمثلة يمكنك اختيار ما يناسبك مثال للتجربة.rar

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

جرب هدا هل يناسبك wor2.xlsm

اخي طريقة وشكل تصمييمك للملف لا تتناسب مع طلبك الاخير سيتم حدف خلايا القوائم المنسدلة مع فقدان التنسيقات والصيغ في الأعمدة المجاورة للجدول في حالة قمت بإعادة النظر في شكل الملف يمكنك استخدام الكود التالي Sub filtre2() Dim f$, lastRow&, Cnt&, n&, lr As Long Dim WS As Worksheet,src As Worksheet f = "من المدرسة" Set WS = Sheets("الصف الثانى ") Set src = Sheets("محولين الى المدرسة") Application.ScreenUpdating = False ' مسح المحتويات السابقة في الورقة الوجهة 'src.Range("B10:U" & src.Rows.Count).ClearContents <<===== غير مفعل lastRow = WS.Range("V" & WS.Rows.Count).End(xlUp).Row lr = src.Range("b" & src.Rows.Count).End(xlUp).Row For Cnt = lastRow To 10 Step -1 If UCase(WS.Range("V" & Cnt).Value) Like UCase(f) Then n = n + 1 src.Range("B" & n + lr & ":U" & n + lr).Value = WS.Range("B" & Cnt & ":U" & Cnt).Value ' حذف الصف من الورقة المصدر بعد نسخه WS.Rows(Cnt).Delete End If Next Cnt Application.ScreenUpdating = True End Sub

يمكنك دالك بدون الحاجة لاظافة اي اكواد جديدة فقط قم بتسمية عنصر Combobox2 طبقا لتسلسل عناصر textbox الموجودة مسبقا على الفورم اي (TEXTBOX62) وتعديل هدا السطر Const dict As Integer = 61 ليصبح بعدد العناصر الموجودة Const dict As Integer = 62 1 ترحيل مع كمبوبوكس.xlsm