نجوم المشاركات

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

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

وعليكم السلام ... اخي الكريم علامة الاختيار لديك واضح انها للسجل وليس الحقل ...

اخي الكريم انا اجبتك على سؤالك ، هل بعد الاجابة تطلب مني طلب اخر لا علاقة له بمشكلتك الم تقرا التوقيع في الاسفل ؟؟؟ معظم الاعضاء الذين يطلبون التعديل اتجاهل طلبهم ولا ادخل في مواضيعهم لكثرة التعديلات واهدار الوقت . هذه المرة ساتجاوز ذلك .ضع هذا في حدث الورقة التي يتم البحث منها . Private Sub Worksheet_Change(ByVal Target As Range) Dim Fnd As Range If Target.Count > 1 Then Exit Sub If Target.Address(0, 0) = "E3" And Target.Value <> "" Then Set Fnd = ورقة2.Range("C:C").Find(Target.Value, , , xlWhole, , , False, , False) If Fnd Is Nothing Then Application.DisplayAlerts = False MsgBox "رقم الهوية" & " " & Target.Value & " " & "غير موجود ، الرجاء المحاولة مرة اخرى", vbExclamation Application.DisplayAlerts = True Exit Sub End If End If End Sub

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

تفضل اخي OfficinaExample.xlsx

اذا كنت تريد المساعدة في المرة القادمة يرجى الاجابة عن الاستفسارات واخذ ملاحظاتي بعين الاعتبار . غير هذا الكود بالكامل وسيختفي الخطا انشاء الله . تم اضافة هذا الجزء بعد اعلان المتغير (المشكلة في الخطا في الخلية التي سألتك عنها ) كما ستلاحظ اذا كانت هناك بيانات سابقة معبئة وكان رقم الهوية فارغ سوف يتم مسحها اذا كان لا يوجد رقم هوية ليس من المنطقي بقاؤها If ورقة2.Cells(2, 16).Text = "#N/A" Then MsgBox "الرجاء تعبئة رقم الهوية ", vbCritical With ورقة1 Range("d5:d13", "g5:g13").ClearContents End With ورقة1.Range("E3").Select Else Private Sub CommandButton2_Click() ورقة2.Range("O2").Value = ورقة1.Range("E3").Value Dim lsearch As Integer If ورقة2.Cells(2, 16).Text = "#N/A" Then MsgBox "الرجاء تعبئة رقم الهوية ", vbCritical With ورقة1 Range("d5:d13", "g5:g13").ClearContents End With ورقة1.Range("E3").Select Else lsearch = ورقة2.Range("P2").Value ورقة1.Range("D5").Value = ورقة2.Cells(lsearch, "B").Value ورقة1.Range("D7").Value = ورقة2.Cells(lsearch, "C").Value ورقة1.Range("D9").Value = ورقة2.Cells(lsearch, "D").Value ورقة1.Range("D11").Value = ورقة2.Cells(lsearch, "E").Value ورقة1.Range("D13").Value = ورقة2.Cells(lsearch, "F").Value ورقة1.Range("G5").Value = ورقة2.Cells(lsearch, "G").Value ورقة1.Range("G7").Value = ورقة2.Cells(lsearch, "H").Value ورقة1.Range("G9").Value = ورقة2.Cells(lsearch, "I").Value ورقة1.Range("G11").Value = ورقة2.Cells(lsearch, "J").Value ورقة1.Range("G13").Value = ورقة2.Cells(lsearch, "K").Value MsgBox "تم استخراج البيانات بنجاح ", vbInformation, "رسالة تأكيد" End If End Sub

=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

طيب ... جرب كما في الصورة ....

مشاركة مع استاذي كانوري

اولا اسف للتاخر في الرد لظروف السفر .... طيب طبق ما في الصورة ......

تفضل .. ابقيت على التقرير الاصلي فقد تكون بحاجة لطباعة اسم محدد وعملت لك زر جديد لطباعة الكل كشوفات نهاية2.rar

وعليكم السلام ورحمة الله وبركاته ..جرب اخي وضع هدا الكود Sub impr_DocWord_MH() Dim WordApp As Object, worddoc As Object Application.ScreenUpdating = False Set WordApp = CreateObject("Word.Application") 'قم بوضع ملف الوورد في نفس مسار ملف الاكسيل مع تغيير الاسم باسم الملف الخاص بك Set worddoc = WordApp.Documents.Open(ThisWorkbook.Path & "\TEST.docx", ReadOnly:=True) WordAppActiveDocument.PrintOut 'تحديد أرقام الصفحات المراد طباعتها 'WordApp.ActiveDocument.PrintOut Pages:="2" Application.Wait Now + TimeSerial(0, 0, 2) worddoc.Close savechanges:=False WordApp.Quit Set worddoc = Nothing Set WordApp = Nothing Application.ScreenUpdating = True End Sub وفي المرفقات ملف للتجربة طباعة ملف وورد من داخل الاكسيل.rar