تعديل كود ترحيل

[mohamed elforse]

السلام عليكم ورحمة الله وبركاتة

الرجاء التكرم بالمساعدة في حل عدم تشغيل الكود في الملف المرفق وهو عبارة عن اخذ Data الموجودة في شيت تقرير الوردية اليومي و ترحيلة الي شيت مجمع مع الاخذ في الاعتبار بامكانية عمل Insert في شيت تقرير الوردية اليومي ما بين سطر 7 الي سطر10 و كذلك مابين سطر 13 الي سطر 16 

وشكرا

تقرير السبت نهاري - Copy.xlsm

[حسونة حسين]

وعليكم السلام ورحمه الله وبركاته

تفضل هذا الكود ( تعديل لكودك )

Sub ترحيل_البيانات()
    Dim Lr As Long, SH As Worksheet, WS As Worksheet
    Set SH = ThisWorkbook.Worksheets("تقرير الوردية اليومي")
    Set WS = ThisWorkbook.Worksheets("شيت مجمع")
    Application.ScreenUpdating = False
    If MsgBox("انت تريد ترحيل هذا الايصال . هل تريد الاستمرار ؟", vbYesNo + vbQuestion) = vbNo Then
        Exit Sub
    End If
    If SH.Cells(4, 3).Value <> "" Then
        With SH
            .Activate
            .Unprotect Password:="011005051002018"
            WS.Unprotect Password:="011005051002018"
            If WS.FilterMode Then
                WS.ShowAllData
            End If
            Lr = WS.Cells(Rows.Count, "G").End(xlUp).Row + 1
            WS.Range("A" & Lr).Resize(4) = .Range("C4").Value
            WS.Range("A" & Lr).Resize(4).NumberFormat = "dd/mm/yyyy"
            WS.Range("B" & Lr).Resize(4) = .Range("E4").Value
            WS.Range("C" & Lr).Resize(4) = .Range("G4").Value
            WS.Range("D" & Lr).Resize(4) = .Range("I4").Value
            WS.Range("E" & Lr).Resize(4) = .Range("K4").Value
            WS.Range("F" & Lr).Resize(4) = .Range("N4").Value
            .Range("B7:M10").Copy
            WS.Range("G" & WS.Cells(Rows.Count, "G").End(xlUp).Row + 1).PasteSpecial xlPasteValues
            .Range("B13:P16").Copy
            WS.Range("S" & WS.Cells(Rows.Count, "S").End(xlUp).Row + 1).PasteSpecial xlPasteValues
            .Range("C4,G4,I4,K4,N4,D7:J10,L7:P10,D13:I16,L13:P16").ClearContents
            .Protect Password:="011005051002018", AllowFiltering:=True, AllowFormattingCells:=True
            Application.Goto WS.Range("C4")
            WS.Protect Password:="011005051002018", AllowFiltering:=True, AllowFormattingCells:=True
        End With
    Else
        MsgBox "الرجاء وضع التاريخ و ملئ البيانات"
        SH.Activate
        SH.Range("C4").Select
        Exit Sub
    End If
    Application.ScreenUpdating = True
End Sub

 

[mohamed elforse]

ا / حسونة حسين

تحية طيبة وبعد ,,,

اولا شكرا جزيلا علي الكود و علي المجهود المبزول 

ثانيا اريد او اوضح عند زيادة عدد الاسطر ما بين سطر 7 الي سطر 10 او ما بين سطر رقم 13 الي 16 ادي الي اختلاف بيانات الترحيل 

 

ومرفق الملف بعد اضافة بعض الاسطر ما بين 7 الي 10 او من 13 الي 16

تقرير السبت نهاري - Copy.xlsm

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

بالإذن

ربما

Sub test()
Dim r As Range
Dim a
Dim k&, c&
k = 7
Application.ScreenUpdating = False
With Sheets("تقرير الوردية اليومي")
a = .Cells(4, 2).Resize(, 13)
For Each r In .Range("B5:B" & Cells(Rows.Count, 2).Row).SpecialCells(2, 23).Areas
 .Cells(r(1).Row, 2).Offset(1).Resize(r.Rows.Count, .Cells(r(1).Row, Columns.Count).End(xlToLeft).Column - 1).Copy
 Sheets("شيت مجمع").Cells(2, k).PasteSpecial Paste:=xlPasteValues
k = k + 12
 c = r.Rows.Count - 1
Next
Sheets("شيت مجمع").Cells(2, 1).Resize(c, 6) = Application.Index(a, 1, Array(2, 4, 6, 8, 10, 13))
End With
Application.ScreenUpdating = True
End Sub

 

[mohamed elforse]

ا / محي الدين ابو البشر

تحية طيبة وبعد ,,,

اولا شكرا جزيلا علي الكود و علي المجهود المبزول و الكود يعمل بنجاح

ثانيا اريد اود اوضح ان الكود يعمل علي عمل Replace للبيانات المرحلة سابقا و ليس الاضافة علي البيانات السابقة 

وشكرا

 

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

هكذا؟

Sub test()
Dim r As Range
Dim a
Dim k&, c&, z&
k = 7
Application.ScreenUpdating = False
With Sheets("تقرير الوردية اليومي")
a = .Cells(4, 2).Resize(, 13)
For Each r In .Range("B5:B" & Cells(Rows.Count, 2).Row).SpecialCells(2, 23).Areas
 .Cells(r(1).Row, 2).Offset(1).Resize(r.Rows.Count, .Cells(r(1).Row, Columns.Count).End(xlToLeft).Column - 1).Copy
 z = Sheets("شيت مجمع").Cells(Rows.Count, 1).End(xlUp).Row + 1
 Sheets("شيت مجمع").Cells(z, k).PasteSpecial Paste:=xlPasteValues
k = k + 12
 c = r.Rows.Count - 1
Next
Sheets("شيت مجمع").Cells(z, 1).Resize(c, 6) = Application.Index(a, 1, Array(2, 4, 6, 8, 10, 13))
End With
Application.ScreenUpdating = True
End Sub