اذهب الي المحتوي
أوفيسنا

كود ترحيل


إذهب إلى أفضل إجابة Solved by محمد هشام.,

الردود الموصى بها

لسلام عليكم

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

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

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

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

 

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

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

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

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

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

 

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

رابط هذا التعليق
شارك

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

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

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

تم تعديل بواسطه محمد هشام.
رابط هذا التعليق
شارك

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

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

السلام عليكم 

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

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

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

رابط هذا التعليق
شارك

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

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

 

تم تعديل بواسطه محمد هشام.
  • Thanks 1
رابط هذا التعليق
شارك

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

تم تعديل بواسطه محمد هشام.
  • Like 2
رابط هذا التعليق
شارك

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

تم تعديل بواسطه محمد هشام.
  • Thanks 1
رابط هذا التعليق
شارك

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

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

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

 

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

 

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

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

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

رابط هذا التعليق
شارك

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

img?id=575866

img?id=575867

ولجلب البيانات استخدم الكود التالي 

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

  • Thanks 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information