ابو منذر عبد الله قام بنشر ديسمبر 28, 2023 مشاركة قام بنشر ديسمبر 28, 2023 لسلام عليكم اخواني استفدت كثيرا من خبرتكم و حاولت انجاز هذا العمل حيث اريد ترحيل رقم في خلية رقم الغياب الى اوراق محدد حسب الرمز المحدد و الى الشخص المحدد برقمه و بالتاريخ في راس عمود ادخال البيانات H حيث فيه اكثر من 2000 شخص العمل هذا اعرف انه معقد و طويل و احتاجه حيث حاولت الاستفادة من المنتدى بالاكواد اللازمة و لكنني لم افلح و اكون جد شاكرا لكم لسعة صدوركم و مساعدتي على هذا العمل و ادعو الله ان يطيل اعماركم و يزيدها في ميزان حسناتكم و منكم استفدنا و و لكم الفضل في نجاح هذا العمل الذي سهل على الكثير الكثير من العمال من مهامهم و السلام عليكم و بارك الله فيك على المساعدة اريد عند اختيار تاريخ و اختيار نوع الغياب و عدد الغياب ثم اقوم بالترحيل فانه يرحل الى ضفحة نوغ الغياب و الى العمود الذي به نفس تاريخ الادخال و في البحث فانه يجلب لي مجموع الغياب و حسب النوع بين تاريخين الغمل معقد و المطلوب ربما كبير و يتطلب جهد و مشكوور على المساعدة و جزاك الله كل خير ترحيل بيانات 1.xlsx رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر يناير 5 مشاركة قام بنشر يناير 5 (معدل) اخي لقد تمت تجربة الكود ويشتغل بشكل جيد هدا اخر تعديل على الملف لانه صراحة الموضوع اخد اكثر من حقه لا يعقل انك لم تستطع تعديل سطر واحد لتفريغ البيانات بعد تزويدك بكل هده الحلول ترحيل بيانات 4.xlsm تم تعديل يناير 5 بواسطه محمد هشام. رابط هذا التعليق شارك More sharing options...
belkacem24 قام بنشر يناير 5 مشاركة قام بنشر يناير 5 لقد قمت بوضع كود الاستاذ محمد هشام. ـ وجربته هو جيد ـ واره احسن كود ـ عليك بتجريبه ، واخباري ترحيل بيانات 2 (4).xlsm 1 رابط هذا التعليق شارك More sharing options...
ابو منذر عبد الله قام بنشر يناير 5 الكاتب مشاركة قام بنشر يناير 5 3 ساعات مضت, belkacem24 said: لقد قمت بوضع كود الاستاذ محمد هشام. ـ وجربته هو جيد ـ واره احسن كود ـ عليك بتجريبه ، واخباري السلام عليكم معذرة منكم و جزاكم الله كل خير على مساعدتي الكود لم يعمل عندي لا ادري يخرج رسالة ترحيل بيانات 2 (4).xlsm 166.15 kB · 2 downloads رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر يناير 5 مشاركة قام بنشر يناير 5 (معدل) أرفق ملفك الأصلي مع صورة توضح الخطأ الذي يظهر معك هل قمت بتجربة الملف الذي رفعت لك في آخر مشاركة ؟ تم تعديل يناير 5 بواسطه محمد هشام. 1 رابط هذا التعليق شارك More sharing options...
ابو منذر عبد الله قام بنشر يناير 5 الكاتب مشاركة قام بنشر يناير 5 3 دقائق مضت, محمد هشام. said: أرفق ملفك الأصلي مع صورة توضح الخطأ الذي يظهر معك هل قمت بتجربة الملف الذي رفعت لك في آخر مشاركة ؟ Sub Copy_V2() Dim wsdest As Worksheet Dim lRow As Long, i As Long, Réf As Variant Dim rng As Range, xDate As Range Dim WS As String, j As Range Set wsdata = Worksheets("ÇÏÎÇá ÇáÈíÇäÇÊ"): Set r = wsdata.Range("H2") On Error Resume Next lRow = wsdata.Columns("G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 If WorksheetFunction.CountA(wsdata.Range("H4:H" & lRow)) = 0 Then MsgBox "íÑÌì ÇáÊÇßÏ ãä ãáÆ ÚãæÏ ÚÏÏ ÇáÛíÇÈ", vbExclamation: Exit Sub If WorksheetFunction.CountA(wsdata.Range("G4:G" & lRow)) = 0 Then MsgBox "íÑÌì ÇáÊÇßÏ ãä ãáÆ ÚãæÏ äæÚ ÇáÛíÇÈ", vbExclamation: Exit Sub For i = 4 To lRow If wsdata.Cells(i, "G") <> "" Then WS = wsdata.Cells(i, "G"): Set j = wsdata.Range("G4:H" & lRow) Set Wdest = Worksheets(WS) Réf = wsdata.Cells(i, "A").Value Set rng = Wdest.Columns("A").Find(what:=Réf, LookIn:=xlValues, LookAt:=xlWhole) If Not rng Is Nothing And Wdest.Cells(i, "A").Value <> Empty Then For Each xDate In Wdest.Range("H3", Wdest.Cells(3, Wdest.Cells(3, Columns.Count).End(xlToLeft).Column)) If xDate = r Then Wdest.Cells(rng.Row, xDate.Column) = wsdata.Cells(i, "H") Next End If End If Next i j.ClearContents On Error GoTo 0 End Sub tفي هذا السطر Set wsdata = Worksheets("ÇÏÎÇá ÇáÈíÇäÇÊ") هذا هو Doc111.docx رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر يناير 5 مشاركة قام بنشر يناير 5 (معدل) Set wsdata = Feuil2 ملاحظة: إذا كنت تقوم بنسخ الكود فقط إلى ملف الأصلي. حاول تعديل أسماء أوراق العمل لديك لتتطابق مع الأسماء الموجودة في القائمة المنسدلة في عمود G لأنها غير مطابقة وتم إصلاحها في الملفات السابقة. مجرد وجود اختلاف في حرف أو فراغ معين. قد يسبب عدم اشتغال الكود معك بشكل جيد ترحيل بيانات5.xlsm تم تعديل يناير 5 بواسطه محمد هشام. 2 رابط هذا التعليق شارك More sharing options...
ابو منذر عبد الله قام بنشر يناير 5 الكاتب مشاركة قام بنشر يناير 5 11 دقائق مضت, محمد هشام. said: Set wsdata = Feuil2 ملاحظة: إذا كنت تقوم بنسخ الكود فقط إلى ملف الأصلي. حاول تعديل أسماء أوراق العمل لديك لتتطابق مع الأسماء الموجودة في القائمة المنسدلة في عمود G لأنها غير مطابقة وتم إصلاحها في الملفات السابقة. مجرد وجود اختلاف في حرف أو فراغ معين. قد يسبب عدم اشتغال الكود معك بشكل جيد ترحيل بيانات5.xlsm 171.79 kB · 0 downloads أخي هشام و بلقاسم كل عبارات الشكر و التقدير لا تكفي لمكافئتكم بوركتم و جزاك الله كل الخير و ربي يعطيكم ما تتمناو الكود روعة روعة روعة يعطيكم الصحة رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر يناير 5 مشاركة قام بنشر يناير 5 العفو أخي الكريم يسعدنا أننا استطعنا مساعدتك 1 رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر يناير 6 أفضل إجابة مشاركة قام بنشر يناير 6 (معدل) مع بعض التعديلات البسيطة Sub Find_And_copy() ' to Update 06 / 01 / 2024 Dim c As Range: Dim Col As Range Dim r As Range: Dim Rng As Range Dim WS As String: Dim j As Long Dim lastrow As Long: Dim MyData As Worksheet: Set MyData = Feuil2 On Error Resume Next If MyData.[H2] = "" Then: MsgBox "المرجوا إدخال تاريخ الغياب", vbInformation, "admin": Exit Sub lastrow = MyData.Columns("G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row If WorksheetFunction.CountA(MyData.Range("G4:G" & lastrow + 1)) = 0 Then MsgBox "يرجى ملئ بيانات" & " : " & [G3], vbExclamation: Exit Sub If WorksheetFunction.CountA(MyData.Range("H4:H" & lastrow + 1)) = 0 Then MsgBox "يرجى ملئ بيانات" & " : " & [H3], vbExclamation: Exit Sub For j = 4 To lastrow If MyData.Range("G" & j) <> "" Then: WS = MyData.Cells(j, "G") Set MyDest = Worksheets(WS) With Application .ScreenUpdating = False With MyDest For Each r In MyDest.Range("A5", .Cells(Rows.Count, 1).End(xlUp)) Set Rng = MyData.Range("A:A").Find(r.Value, , xlValues, xlWhole) If Not Rng Is Nothing Then For Each c In Application.Intersect(MyData.UsedRange, MyData.[H2]) If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then Set Col = MyDest.Rows(3).Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole) If Col Is Nothing Then: MsgBox "المرجوا التحقق من تاريخ الإدخال" & " : " & MyData.[H2].Value, vbInformation, "تعليمات": Exit Sub If Not Col Is Nothing And Rng.Offset(, 6).Value = MyDest.Name Then MyDest.Cells(r.Row, Col.Column).Value = Rng.Offset(, 7).Value End If End If Next c End If Next End With .ScreenUpdating = True End With Next j On Error GoTo 0 MyData.Range("G4:H" & lastrow + 1).ClearContents: [H2] = Empty MsgBox "تم ترحيل البيانات بنجاح ", vbInformation, "admin" End Sub ترحيل بيانات 6.xlsm تم تعديل يناير 6 بواسطه محمد هشام. 1 رابط هذا التعليق شارك More sharing options...
ابو منذر عبد الله قام بنشر يناير 6 الكاتب مشاركة قام بنشر يناير 6 8 ساعات مضت, محمد هشام. said: مع بعض التعديلات البسيطة جزاك الله و بوركت ترحيل بيانات 6.xlsm 189 kB · 6 downloads يا سلام الكود أصبح يبحث عن الرقم و رأس العمود و يرحل ,,,, روعة روعة هذا هو المطلوب يا أخي كفيت و وفيت و كل مساعداتك استفاد منها الكثير و دعا لك الكثير جزاك الله كل خير رابط هذا التعليق شارك More sharing options...
ابو منذر عبد الله قام بنشر يناير 6 الكاتب مشاركة قام بنشر يناير 6 لقد اضفت له خاصية البحث بقائمة منسدلة و هكذا ارحل ما اريد فقط ترحيل بيانات 6.xlsm رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر يناير 6 مشاركة قام بنشر يناير 6 تمام لاستخراج الرموز بدون تكرار في ورقة ادخال البيانات الخلية P18 ضع المعادلة التالية مع سحبها للاسفل =IFERROR(INDEX($L$18:$L$200; MATCH(0; IF(ISBLANK($L$18:$L$200); 1; COUNTIF(P17:$P$17; $L$18:$L$200)); 0));"") مع تسمية النطاق بالشكل التالي وليكن مثلا Clé =OFFSET('ادخال البيانات'!$P$18;0;0;COUNT(IF('ادخال البيانات'!$P$18:$P$10000="";"";1));1) ولجلب البيانات استخدم الكود التالي Sub Search() Dim WSdata As Worksheet: Dim WSEntry As Worksheet: Set WSdata = Feuil1: Set WSEntry = Feuil2 Dim Clé As String, all As String, lr As Long, F&, Col& Dim a As Range, b As Range, rngCell As Range With Application .ScreenUpdating = False .Calculation = xlCalculationManual lr = WSdata.Cells(WSdata.Rows.Count, "C").End(xlUp).Row Clé = WSEntry.[G1]: all = "الكل" WSEntry.Range("A4:F500").ClearContents For Col = 4 To lr If WSdata.Cells(Col, "H") Like Clé Then Set a = WSdata.Range(WSdata.Cells(Col, 3), WSdata.Cells(Col, 8)) WSEntry.Cells(Rows.Count, "a").End(xlUp).Offset(1, 0).Resize(, 6).Value = a.Value End If If Clé Like all Then Set b = WSdata.Range(WSdata.Cells(Col, 3), WSdata.Cells(Col, 8)) WSEntry.Cells(Rows.Count, "a").End(xlUp).Offset(1, 0).Resize(, 6).Value = b.Value End If Next Col F = WSEntry.Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = WSEntry.Range("A4 :H" & F) WSEntry.Range("A4:H500").Borders.LineStyle = xlNone For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next If Application.WorksheetFunction.CountA(WSEntry.Range("A4:H5")) = 0 Then MsgBox "ليس هناك بيانات مطابقة لمعايير الفلترة الحالية" & " / " & Clé, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" End If .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub وفي حدث ورقة ادخال البيانات Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Target.Worksheet.Range("G1")) Is Nothing Then If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub Call Search Application.EnableEvents = True End If On Error GoTo 0 End Sub ترحيل بيانات 7.xlsm 1 رابط هذا التعليق شارك More sharing options...
ابو منذر عبد الله قام بنشر يناير 6 الكاتب مشاركة قام بنشر يناير 6 جزاءك عند الله ...... و الله اكرمتني و اتحفتني شكرا شكرا شكرا لك رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان