محمد هشام.

تختفي لانك انت الذي أنشأت الكود بتلك الطريقة ليس أنا !!!!!!!!! بالنسبة للترحيل هي فعلا عند إلغاء مربع CheckBox3 لا يتم ترحيل نسبة الضريبة قد تمت التجربة قبل رفع الملف اخي

أخي قم بتحميل الملف الأخير قد تم تعديل شرط CheckBox3 أما بالنسبة لكود الفاتورة أن شاء الله سوف أحاول إنشاءه باذن الله

تفضل اخي لكي تفهم الموضوع اكثر تم اضافة ظهور قيمة الضريبة بمجرد كتابة المبلغ والعدد لكي نتمكن من نسخها الى تكست بوكس 1 وبالتالي يتم ترحيلها الى الشيت الكود السابق يعتمد على ظهور قيمة الضريبة عند الظغط على زر اضافة فقط وبهذا عند تنفيد الكود سوف يجد تكست بوكس (bt8) فارغة !!!!!!!!!! AAAAA(1).xlsm

السلام عليكم اخي لقد لاحظت انه عند كل ترحيل جديد يتم مسح البيانات القديمة هل هي عن قصد ؟

السلام عليكم ورحمة الله وبركاته ..جرب أخي هل هذا هو المطلوب AAAAA(1).xlsm

تفضل اخي لاكن الترتيب حسب اوراق العمل تم اضافة الاكواد التالية كود لترتيب التاريخ من الاصغر للاكبر يتم تفعيله تلقائيا عند الدخول على اليوزفورم. Sub MH_sort() Dim ws As Worksheet Application.ScreenUpdating = False Dim LR As Long For Each ws In ThisWorkbook.Worksheets LR = ws.Range("b" & ws.Rows.Count).End(xlUp).Row If (ws.Name <> "Database") Then With ws.Sort .SortFields.Clear .SortFields.Add2 Key:=ws.Range("e5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange ws.Range("b4:L" & LR) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End If Next ws Sheets("المبيعات").Activate Range("A1").Select وهدا لالغاء الفراغ الموجود في ComboBox1 Private Sub UserForm_Initialize() Dim I As Integer With Sheets("Database") For r = 2 To .Range("c" & .Rows.Count).End(xlUp).Row If .Range("c" & r) <> "" Then ComboBox1.AddItem .Range("c" & r) End If Next r End With End Sub AAAAA.xlsm

تفضل اخي جرب 'Option Explicit Private Sub ComboBox1_Change() Sheet2.Range("s1") = ComboBox1.Text TextBox1.Value = Sheets("المبيعات").Range("R1").Value Dim a Dim i As Long Me.ComboBox1.Text = StrConv(Me.ComboBox1.Text, vbProperCase) Me.ListBox1.Clear For Each ws In ActiveWorkbook.Sheets With ws For i = 5 To Application.WorksheetFunction.CountA(.Range("b:b")) a = Len(Me.ComboBox1.Text) If Left(.Cells(i, 8).Value, a) = Left(Me.ComboBox1.Text, a) Then Me.ListBox1.AddItem .Cells(i, 1).Value Me.ListBox1.List(ListBox1.ListCount - 1, 1) = .Cells(i, 2).Value Me.ListBox1.List(ListBox1.ListCount - 1, 2) = .Cells(i, 3).Value Me.ListBox1.List(ListBox1.ListCount - 1, 3) = .Cells(i, 5).Value Me.ListBox1.List(ListBox1.ListCount - 1, 4) = .Cells(i, 6).Value Me.ListBox1.List(ListBox1.ListCount - 1, 5) = .Cells(i, 8).Value Me.ListBox1.List(ListBox1.ListCount - 1, 6) = .Cells(i, 9).Value End If Next i End With Next ws End Sub '''''''''''''''''''' Private Sub CommandButton1_Click() Dim z As Control For Each z In UserForm1.Controls If TypeName(z) = "TextBox" Then z.Value = "" ListBox1.Clear End If Next z End Sub '''''''''''''''''''' Private Sub CommandButton2_Click() Dim ctl As Control For Each ctl In Me.Controls Select Case TypeName(ctl) Case "ComboBox", "TextBox" ctl.Text = "" End Select Next ctl End Sub '''''''''''''''''''' Private Sub Exitbutton_Click() UserForm1.Hide End Sub AAAAA.xlsm

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

تمام بالنسبة لتكست بوكس ...اما بالنسبة للاعمدة الاولى لاحظت انك شطبت عليها هل سيتم حدفها !!!!!

السلام عليكم ورحمة الله تعالى وبركاته جرب اخي انشاء مجلد في اي مكان على الجهاز وقم بوضع الملف بداخله ثم اضف الكود التالي Sub convert_to_CSV() Dim st As Worksheet Dim path As String Application.ScreenUpdating = False path = ActiveWorkbook.path & "\" & Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1) For Each st In Worksheets st.Copy ActiveWorkbook.SaveAs Filename:=path & "_" & st.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False ActiveWorkbook.Close False Next Application.ScreenUpdating = True End Sub اليك الملف عليه الكود كما سبق الدكر ضعه في مجلد منفضل وقم بتشغيل الكود بالتوفيق..... ملف الاكسيل المحول من وورد.xlsm

السلام عليكم ورحمة الله تعالى وبركاته اخي مزيدا من التوضيح بخصوص الثلاثة اعمدة الاولى و ما هي النتيجة المتوقعة في TextBox1 في انتظارك أخي ابو محمد نصري

تفضل أخي رغم أنني استخدم اللغة الفرنسية على الجهاز قمت بتغييرها 😄 https://streamable.com/ljz0bf

السلام عليكم ورحمة الله تعالى وبركاته تفضل اخي الكريم يمكنك وضع الكود التالي وفلترة العمود بعشرة اعداد دفعة واحدة قابلة للزيادة . Sub Filter_() Dim Criteria_MH(100) As String Dim i As Integer Application.ScreenUpdating = False Sheets("ارقام الفلترة").Activate Range("A2:A12").Select For i = 0 To Selection.Count Criteria_MH(i) = Selection(i) Next Sheets("الجدول").Range("A3:A100").AutoFilter Field:=1, Criteria1:=Criteria_MH, Operator:=xlFilterValues Sheets("الجدول").Activate Application.ScreenUpdating = True End Sub tahar-MH.xlsm

=IF(IF(NB.SI($B$1:B2;B2)=1;MAX($A1:A$1)+1;"")<>"";SI(NB.SI($B$1:B2;B2)=1;MAX($A1:A$1)+1;"");INDEX($A$1:A1;EQUIV(B2;$B$1:B2;0))) تفضل جرب اخي OfficinaExample(3).xlsx

تفضل اخي المشكلة في تنسيق الخلايا ليس اكثر تم تعديل الملف اطفال_MH-3.xlsm

السلام عليكم ورحمة الله تعالى وبركاته نعم اخي الفاضل اتضحت الفكرة وللعلم اخي الفاضل استوعاب الفكرة وفهم المطلوب يمثل 90 في المئة من الحل .وهدا ما يجعلني لا اخوض في كثير من المداخلات بسبب عدم شرح السائل لطلبه جيدا او وضع نمودج للنتائج المتوقعة . على العموم اتمنى ان اكون قد استوعبت طلبك اخي الكريم 😁 اليك كودين ولك الاختيار هدا كود لنقل البيانات من الاعمدة الى الصفوف حسب الرمز المكرر من شيت اطفال الى شيت اخر (DATA ) Sub Transpose_to_columns() Dim inp_arr, i As Long, out_arr, dict As Object, key As String Set dict = CreateObject("Scripting.Dictionary") With Sheets("اطفال") inp_arr = .Range(.Cells(2, 5), .Cells(.Rows.Count, 1).End(xlUp)).Value End With For i = 1 To UBound(inp_arr) key = CStr(inp_arr(i, 1)) If dict.Exists(key) Then dict(key) = dict(key) & ";" & inp_arr(i, 3) & ";" & inp_arr(i, 4) & ";" & inp_arr(i, 5) Else dict.Add key, inp_arr(i, 3) & ";" & inp_arr(i, 4) & ";" & inp_arr(i, 5) End If Next i ReDim out_arr(1 To dict.Count, 1 To 4) For i = 0 To dict.Count - 1 out_arr(i + 1, 1) = dict.Keys()(i) out_arr(i + 1, 2) = dict.Items()(i) Next i With Sheets("data") .Cells(2, 1).Resize(dict.Count, 2) = out_arr .Cells(2, 2).Resize(dict.Count, 1).TextToColumns Destination:=.Cells(2, 2), DataType:=xlDelimited, Semicolon:=True End With Set dict = Nothing Sheets("data").Activate End Sub وهدا كود لنقل البيانات من الاعمدة الى الصفوف حسب الرمز المكرر في نفس الشيت (اطفال) Sub MH_transpose_colmns() Dim der, t, ref, nbr&, i&, i1&, i2& Application.ScreenUpdating = False With ActiveSheet If .FilterMode Then .ShowAllData der = Cells(Rows.Count, "a").End(xlUp).Row Columns("a:e").Resize(der).Sort key1:=Range("a1"), order1:=xlAscending, _ key2:=Range("b1"), order2:=xlAscending, Header:=xlYes t = Columns("a:e").Resize(der + 1).Value2 ReDim r(1 To 1, 1 To Columns.Count - Range("h1").Column - 1) Range(Range("h1"), Cells(Rows.Count, Columns.Count)).Clear ref = t(2, 1): i1 = 2: i2 = i1: nbr = 1: r(1, nbr) = ref Do If t(i2, 1) = ref Then nbr = nbr + 1: r(1, nbr) = t(i2, 3) nbr = nbr + 1: r(1, nbr) = t(i2, 4) nbr = nbr + 1: r(1, nbr) = t(i2, 5) i2 = i2 + 1 Else Cells(Rows.Count, "h").End(xlUp).Offset(1).Resize(, nbr) = r ReDim r(1 To 1, 1 To Columns.Count - Range("h2").Column - 1) i1 = i2: i2 = i1: ref = t(i2, 1): nbr = 1: r(1, nbr) = ref If ref = "" Then Exit Do End If Loop End With Application.ScreenUpdating = True End Sub واليك الملف مع اضافة الاكواد ....في حالة الرغبة في الاضافة او التعديل لا تتردد اخي الكريم.بالتوفيق ... اطفال_MH.xlsm

تفضل اخي OfficinaExample.xlsx

السلام عليكم ورحمة الله تعالى وبركاته على حسب ما فهمت من طلبك اخي المسالة لا تحتاج برمجة على ما اظن فقط خمس دقائق لاستخراج البيانات.تفضل اخي جرب ادا لم اكن مخطئ فهدا طلبك اطفال(3).xlsx

تفضل اخي جرب ..ملاحظة لكي يشتغل معك الكود دون مشاكل حاول عدم حدف عمود المبلغ من الملف Private Sub Worksheet_Change(ByVal Target As Range) Dim AncValeur, NouvValeur, Cel, Col Dim rRange Application.ScreenUpdating = False If Not Intersect(Target, Range("C5:C15,F5:F15")) Is Nothing And Target.CountLarge = 1 Then Application.EnableEvents = False NouvValeur = Target Application.Undo AncValeur = Target.Value If AncValeur = "" And NouvValeur <> "" Then Target = NouvValeur Set Cel = Sheets("1").Range("3:3").Find("المبلغ") If Not Cel Is Nothing Then Col = Cel.Column For i = 1 To 12 With Sheets("" & i & "") .Activate .Range(.Cells(3, Col - 2), .Cells(15, Col - 1)).Select Selection.Copy Selection.Insert Shift:=xlToRight Application.CutCopyMode = False .Range(.Cells(3, Col), .Cells(3, Col + 1)).Value = Target End With Next i Sheets("المريا").Select End If End If Application.EnableEvents = True End If End Sub -2ادراج الاعمدة.xlsm

وعليكم السلام ورحمة الله وبركاته أخي هل سيتم نسخ القيم الموجودة في عمود القرش والجنيه إلى الشيتات عند إضافة الأعمدة؟ او يتم نسخ رؤوس الأعمدة المذكورة فقط .

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

الكود ينسخ المعادلات في صف الإجمالي. هو المفروض يتم نسخ المعادلة في أي صف ؟ . اما بالنسبة لاضافة المعادلات لجميع الشيتات يمكنك جعل الكود بهده الطريقة Sub y() Dim LR As Long Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets LR = ws.Range("c" & ws.Rows.Count).End(xlUp).Row If (ws.Name <> "الترحيل") Then With ws ws.Range("E" & LR).Formula = "=Sum(E16:E" & LR - 1 & ")" ws.Range("d" & LR).Formula = "=Sum(d16:d" & LR - 1 & ")" ws.Range("f" & LR).FormulaR1C1 = "=RC[-1]-RC[-2]" ws.Range("g" & LR).FormulaR1C1 = "=RC[-1]-RC[-2]" End With End If Next ws End Sub

السلام عليكم ورحمة الله وبركاته ..جرب وضع هدا الكود اخي Sub ترحيل_قيود() ActiveSheet.unprotect Set ws = ActiveWorkbook.Sheets("الترحيل) Dim cl As Range, i As Integer For i = 1 To Sheets.Count Application.ScreenUpdating = False For Each cl In ws.Range("a13:a" & ws.[a10000].End(xlUp).Row) If cl.Value = Sheets(i).Name Then Sheets(i).Range("a" & Sheets(i).[a10000].End(xlUp).Row + 1).EntireRow.Insert Sheets("الترحيل").Select cl.Offset(0, 2).Resize(1, 5).Copy Sheets(i).Range("a" & Sheets(i).[a10000].End(xlUp).Row + 1).PasteSpecial xlPasteValues End If Next Next Call y Application.ScreenUpdating = True End Sub Sub y() Dim LR As Long Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets Select Case ws.Name Case "100-1", "100-2", "200-1", "200-2", "200-3", "200-4" LR = ws.Range("c" & ws.Rows.Count).End(xlUp).Row ws.Range("E" & LR).Formula = "=Sum(E16:E" & LR - 1 & ")" ws.Range("d" & LR).Formula = "=Sum(d16:d" & LR - 1 & ")" ws.Range("f" & LR).FormulaR1C1 = "=RC[-1]-RC[-2]" ws.Range("g" & LR).FormulaR1C1 = "=RC[-1]-RC[-2]" End Select Next ws Worksheets("الترحيل").Activate End Sub الحسابات.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي Worksh.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته نعم اخي لازم تقوم بتعديل المعادلة على حسب متطلباتك بتغيير الارقام كما في الصورة المرفقة وعليها مثال لطلبك Book1.xlsx