اصلاح خطا فى كود الترحيل

[فوزى فوزى]

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

اصلاح خطأ فى كود الترحيل.xlsm

[lionheart]

In First worksheet in cell AH4 change the month to March then try the following code

Sub Test()
    Dim x, ws As Worksheet, lr As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        With ws
            lr = .Cells(Rows.Count, "B").End(xlUp).Row + 1
            x = Application.Match(.Range("D2").Value2, .Rows(6), 0)
            If Not IsError(x) Then
                .Cells(lr, 1).Value = .Cells(lr, 1).Row - 6
                .Cells(lr, 2).Value = .Range("B2").Value
                .Cells(lr, x).Resize(, .Range("F2").Value).Value = .Range("C2").Value
            End If
        End With
    Application.ScreenUpdating = True
End Sub

 

تم تعديل مارس 13, 2023 بواسطه lionheart

[فوزى فوزى]

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

[lionheart]

Does the code raises any errors? The code is working well on my side. Just select the suitable month as the date in cell D2 is in March and the selected month is February

[فوزى فوزى]

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

[lionheart]

Try

Sub Test()
    Dim x, w, ws As Worksheet, lr As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        With ws
            lr = .Cells(Rows.Count, "B").End(xlUp).Row + 1
            x = Application.Match(.Range("D2").Value2, .Rows(6), 0)
            If Not IsError(x) Then
                w = Application.Match(.Range("B2").Value, .Range("B7:B" & lr), 0)
                If Not IsError(w) Then
                    .Cells(w + 6, x).Resize(, .Range("F2").Value).Value = .Range("C2").Value
                Else
                    .Cells(lr, 1).Value = .Cells(lr, 1).Row - 6
                    .Cells(lr, 2).Value = .Range("B2").Value
                    .Cells(lr, x).Resize(, .Range("F2").Value).Value = .Range("C2").Value
                End If
            End If
        End With
    Application.ScreenUpdating = True
End Sub

 

[محي الدين ابو البشر]

نفس الكود معدل حسب اظروف الراهنة

Sub Trhile()
Dim ws As Worksheet: Set ws = Sheets("البيانات")
Dim sh As Worksheet: Set sh = Sheets("تجميع الغياب")
Dim lr&, r&, col&
 lr = ws.Cells(Rows.Count, 2).End(xlUp).Row + 1
 On Error Resume Next
  r = Range(Cells(7, 2), Cells(7, 2).End(xlDown)).Cells.Find(ws.Range("b2").Value, , , 1).Row
  On Error GoTo 0
  lr = IIf(r = 0, lr, r)
 ws.Cells(lr, 2) = ws.Range("b2").Value
 ws.Cells(lr, ws.Range("A6:AG6").Cells.Find(Split(ws.[d2].Value, "/")(1), , -4163, 1).Column).Resize(, ws.[F2].Value) = ws.[C2].Value

r = sh.Cells.Find(ws.[b2].Value, , , 1).Row
col = sh.Cells.Find(ws.[C2].Value).Column
sh.Cells(r, col).Value = ws.[d2].Value
sh.Cells(r, col).Offset(, 1) = ws.[e2].Value
sh.Cells(r, col).Offset(, 2) = ws.[F2].Value
End Sub

 

[فوزى فوزى]

ليس لدى مااقوله لكم سوى ادام الله عليكم نعمة العلم وعافية الابدان وحفظكم الله من شرور الدنيا والاخرة امين هذا هو المطلوب