كود ترحيل

[ابو منذر عبد الله]

لسلام عليكم

اخواني استفدت كثيرا من خبرتكم و حاولت انجاز هذا العمل 

حيث اريد ترحيل رقم في خلية رقم الغياب  الى اوراق محدد حسب الرمز المحدد و الى الشخص المحدد برقمه و بالتاريخ في راس عمود ادخال البيانات H حيث فيه اكثر من 2000 شخص 

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

و اكون جد شاكرا لكم لسعة صدوركم و مساعدتي على هذا العمل و ادعو الله ان يطيل اعماركم و يزيدها في ميزان حسناتكم و منكم استفدنا و و لكم الفضل في نجاح هذا العمل الذي سهل على الكثير الكثير من العمال من مهامهم 

 

و السلام  عليكم و بارك الله فيك على المساعدة

اريد عند اختيار تاريخ و اختيار نوع الغياب و عدد الغياب ثم اقوم بالترحيل فانه يرحل الى ضفحة نوغ الغياب و الى العمود الذي به نفس تاريخ الادخال

و في البحث فانه يجلب لي مجموع الغياب و حسب النوع بين تاريخين

الغمل معقد و المطلوب ربما كبير و يتطلب جهد

و مشكوور على المساعدة و جزاك الله كل خير

 

ترحيل بيانات 1.xlsx

[محمد هشام.]

اخي لقد تمت تجربة الكود ويشتغل بشكل جيد هدا اخر تعديل على الملف لانه صراحة الموضوع اخد اكثر من حقه

لا يعقل انك لم تستطع تعديل سطر واحد لتفريغ البيانات بعد تزويدك بكل هده الحلول 

ترحيل بيانات 4.xlsm

تم تعديل يناير 5 بواسطه محمد هشام.

[belkacem24]

لقد قمت بوضع كود الاستاذ محمد هشام. ـ  وجربته هو جيد ـ واره احسن كود ـ  عليك بتجريبه ، واخباري

ترحيل بيانات 2 (4).xlsm

[ابو منذر عبد الله]

3 ساعات مضت, belkacem24 said:

لقد قمت بوضع كود الاستاذ محمد هشام. ـ  وجربته هو جيد ـ واره احسن كود ـ  عليك بتجريبه ، واخباري

السلام عليكم 

معذرة منكم و جزاكم الله كل خير على مساعدتي 

الكود لم يعمل عندي لا ادري يخرج رسالة

ترحيل بيانات 2 (4).xlsm 166.15 kB · 2 downloads

[محمد هشام.]

أرفق ملفك الأصلي مع صورة توضح الخطأ الذي يظهر معك 

هل قمت بتجربة الملف الذي رفعت لك  في آخر مشاركة ؟

 

تم تعديل يناير 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

[محمد هشام.]

Set wsdata = Feuil2

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

ترحيل بيانات5.xlsm

تم تعديل يناير 5 بواسطه محمد هشام.

[ابو منذر عبد الله]

11 دقائق مضت, محمد هشام. said:

Set wsdata = Feuil2

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

ترحيل بيانات5.xlsm 171.79 kB · 0 downloads

أخي هشام و بلقاسم كل عبارات الشكر و التقدير لا تكفي لمكافئتكم

بوركتم و جزاك الله كل الخير و ربي يعطيكم ما تتمناو 

الكود روعة روعة روعة يعطيكم الصحة

[محمد هشام.]

العفو أخي الكريم يسعدنا أننا استطعنا مساعدتك 

[محمد هشام.]

مع بعض التعديلات البسيطة 

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 بواسطه محمد هشام.

[ابو منذر عبد الله]

8 ساعات مضت, محمد هشام. said:

مع بعض التعديلات البسيطة 

جزاك الله  و بوركت

 

ترحيل بيانات 6.xlsm 189 kB · 6 downloads

 

يا سلام الكود أصبح يبحث عن الرقم و رأس العمود و يرحل ,,,, روعة روعة هذا هو المطلوب 

يا أخي كفيت و وفيت و كل مساعداتك استفاد منها الكثير و دعا لك الكثير 

جزاك الله كل خير

[ابو منذر عبد الله]

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

ترحيل بيانات 6.xlsm

[محمد هشام.]

تمام لاستخراج  الرموز بدون تكرار في ورقة ادخال البيانات الخلية 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

[ابو منذر عبد الله]

جزاءك عند الله ...... و الله اكرمتني و اتحفتني شكرا شكرا شكرا لك