محمد هشام.

السلام عليكم ورحمة الله تعالى وبركاته جرب اخي انشاء مجلد في اي مكان على الجهاز وقم بوضع الملف بداخله ثم اضف الكود التالي 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

وعليكم السلام ورحمة الله تعلى وبركاته Sub Clear_Cells() Dim mh_last_row As Long Dim k As Long Application.ScreenUpdating = False mh_last_row = Cells(Rows.Count, "d").End(xlUp).Row For k = 4 To mh_last_row If Cells(k, "a").Value = "" Then Range(Cells(k, "d"), Cells(k, "f")).ClearContents Next k Application.ScreenUpdating = True End Sub كود.xlsb

تفضل اخي test_gold.xlsx

تضل اخي الفاضل هدا كود اخر لانشاء ورقة جديدة وتسميتها باخر قيمة موجودة على عمود A Sub Bouton1_Cliquer() Dim lastLine As Integer Dim NameSheet As String Dim MH As Boolean lastLine = ThisWorkbook.Sheets("toutal").Range("A" & Rows.Count).End(xlUp).Row NameSheet = ThisWorkbook.Sheets("toutal").Range("A" & lastLine) MH = feuilleExiste(NameSheet) If MH = True Then MsgBox "يتعذر انشاء ورقة جديدة بسبب وجودها مسبقا او خانة الاسم فارغة", vbInformation Else Worksheets("hakan").Copy After:=Worksheets(Worksheets.Count) ActiveSheet.Name = Worksheets("toutal").Cells(Rows.Count, 1).End(xlUp).Value ThisWorkbook.Sheets("toutal").Activate End If End Sub Function feuilleExiste(FeuilleAVerifier As String) As Boolean On Error Resume Next ThisWorkbook.Sheets(FeuilleAVerifier).Name = Sheets(FeuilleAVerifier).Name feuilleExiste = (Err.Number = 0) End Function mango_MH4.xlsm

هل تقصد أنك تريد عند الكتابة في عمود a يتم إنشاء ورقة جديدة بنفس الإسم في حالة عدم وجودها على الملف او شيئ آخر وضح طلبك أكثر لكي أحاول مساعدتك

1) حاول أخي الفاضل أولا الإنتهاء من تصميم الملف والحصول على الشكل النهائي ، تفاديا لاهدار الوقت وإعادة العمل عليه كل مرة ..... 2) قم بفتح موضوع جديد مع شرح المطلوب جيدا . حتى يستطيع الأساتذة مساعدتك .

السلام عليكم ورحمة الله تعالى وبركاته ..تفضل اخي جرب تم تعديل صيغة الكود Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim e As Integer Dim LastRowInSheet As Long Dim d As Variant Dim f As Variant Dim InputArray As Variant Application.ScreenUpdating = False LastRowInSheet = Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row InputArray = Range("A1:N" & LastRowInSheet) e = d + f For d = 4 To 99 For f = 100 To 1000 Step 100 InputArray(d, 1) = InputArray(d, 3) - InputArray(d, 2) + InputArray(d - 1, 1) InputArray(d, 12) = InputArray(d, 11) * InputArray(d, 10) InputArray(d, 14) = InputArray(d, 13) * InputArray(d, 10) InputArray(d, 10) = InputArray(d, 9) * InputArray(d, 8) InputArray(d + f - 3, 1) = InputArray(d + f - 3, 3) - InputArray(d + f - 3, 2) + InputArray(d + f - 4, 1) InputArray(d + f - 3, 12) = InputArray(d + f - 3, 11) * InputArray(d + f - 3, 10) InputArray(d + f - 3, 14) = InputArray(d + f - 3, 13) * InputArray(d + f - 3, 10) InputArray(d + f - 3, 10) = InputArray(d + f - 3, 9) * InputArray(d + f - 3, 8) Next Next Range("A1:N" & LastRowInSheet) = InputArray Application.ScreenUpdating = True End Sub نمودج-2.xlsb

ماذا تقصد بالاسم مكان الهيبرلنك؟ اذا لم أكن مخطئا فقد فكرة في هذه المسألة ووضعت الكود في حدث الشيت حيث مباشرة عند تغيير إسم الشيت يتم تحديثه تلقائيا في الهيبرلنك دون الظغط على الزر.

يمكنك اخي بجعل الكود بهده الطريقة 'حيث يتم اظهار الرسالة فقط عند كتابة اسم محمد او سعيد فقط Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 And Target.Row > 1 Then If (Target.Offset(0, 2).Value = "") And ((Target.Value = "محمد") Or (Target.Value = "سعيد")) Then MsgBox "تاكد من مركز التكلفة " Target.Offset(0, 2).Select End If End If End Sub رسالة.xlsm

تفضلي اختي الفاضلة Invoices-j.xlsm