طلب تعديل كود استدعاء وترحيل بيانات

[ناصرالمصرى]

اخى ياسر 

السلام عليكم

جارى تحميل المرفق

والله العظيم انا شاكر فضلك

فأنتم جميعا تيجان فوق رأسى

وافر تقديرى واحترامى

 

 

تم تعديل نوفمبر 17, 2015 بواسطه ناصر المصرى

[أبو سجده]

السلام عليكم 

بعد إذن إخوانى الافاضل

الاستاذ القدير / ابو خليل

والاستاذ القدير / احمد يعقوب

والاستاذ القدير / ياسر العربى

وبعد هذه الحلول الرائغة اسمحوا لى بهذة الاضافة

على الاخ / ناصر ان يضع كود التنسيق لآخى القدير الحاج / احمد يعقوب

فى بداية كود استدعاء البيانات ليتم استدعاؤها على النحو المطلوب

ليصبح الكود هكذا

Sub MACRO1()
'äÓÎ ÊäÓíÞ æÑÞÉ 2 Çáì ßá ÇæÑÇÞ ÇáãáÝ
Dim RN1 As Range, SH, ER
'
Sheets("æÑÞÉ2").Select
    Sheets("æÑÞÉ2").Range("A9:J9").Copy
For SH = 2 To Sheets.Count
ER = Sheets(SH).UsedRange.Rows.Count
Set RN1 = Sheets(SH).Range("A8:J" & ER)
    RN1.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    RN1.PasteSpecial Paste:=xlPasteColumnWidths
Next SH
    Application.CutCopyMode = False
End Sub
Sub test()
    Dim Col As New Collection, Arr, i As Long, J As Long
    On Error Resume Next

    Arr = Sheet1.Range("A7:J" & Sheet1.Cells(Rows.Count, "A").End(xlUp).Row).Value
    For i = 2 To UBound(Arr, 1)
        For J = 2 To UBound(Arr, 2)
            Col.Add Key:=J & Chr(2) & Arr(i, 1), Item:=Arr(i, J)
        Next J
    Next i

    With Sheet2.Range("A7:J" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row)
        Arr = .Value
        For i = 2 To UBound(Arr, 1)
            For J = 2 To UBound(Arr, 2)
                Arr(i, J) = Col(J & Chr(2) & Arr(i, 1))
            Next J
        Next i
        .Value = Arr
    End With
End Sub
Sub Bring_Data()
    Dim i As Long
    Dim K As Long
    Dim LastRow As Integer
    Dim SourceSheet As Worksheet
    Set SourceSheet = ThisWorkbook.Sheets("sheet3")
    LastRow = SourceSheet.Range("e" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
        Range("E7").Select
    K = 0
    For i = 8 To LastRow + 8 Step 20
        SourceSheet.Range("E" & i & ":V" & i + 19).Copy
        Range("A" & K + i).Select
        ActiveSheet.Paste
        K = K + 7
    Next
     Application.ScreenUpdating = True
End Sub
Sub Clear_Data()
    Dim LastRow As Integer
    LastRow = Range("a" & Rows.Count).End(xlUp).Row
    Range("A8:V" & LastRow).Clear
End Sub
Sub Clear_Sheet2_Data()
    Dim LastRow As Integer
    LastRow = Sheet2.Range("a" & Rows.Count).End(xlUp).Row
    Sheet2.Range("B8:J" & LastRow).Clear
End Sub
Sub Call_All()
    Dim myConfirm
    myConfirm = MsgBox("åá ÊÑíÏ äÓÎ ÇáÊäÓíÞÇÊ", vbYesNo)
    If myConfirm = vbYes Then MACRO1
    myConfirm = MsgBox("åá ÊÑíÏ ÇÓÊÏÚÇÁ ÇáÈíÇäÇÊ", vbYesNo)
    If myConfirm = vbYes Then test
    myConfirm = ""
    myConfirm = MsgBox(" åá ÊÑíÏ ÊÑÍíá ÇáÈíÇäÇÊ", vbYesNo)
    If myConfirm = vbYes Then
        Sheet5.Select
        Bring_Data
        Sheet2.Select
    End If
   myConfirm = ""
   myConfirm = MsgBox("åá ÊÑíÏ ãÓÍ ãÍÊæíÇÊ äØÇÞ ÇáÈíÇäÇÊ", vbYesNo)
   If myConfirm = vbYes Then Clear_Sheet2_Data
   myConfirm = ""
   myConfirm = MsgBox("åá ÊÑíÏ ÇáÈÏÁ Ýì äÞá ÇáÈíÇäÇÊ áØÈÇÚÉ ÇáßÔæÝ", vbYesNo)
   If myConfirm = vbYes Then StartTimer
End Sub

أرجو أن أكون قد وفقت فى تقديم مايصبوا اليه أخى الفاضل ناصر المصرى

تقبلوا جميعا وافر احترامى وجزاكم الله خيرا

[ناصرالمصرى]

الاستاذ القدير / سعيد بيرم

طوق نجاتى

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

حمدا لله على سلامتكم وشفاك الله وعفاك

لقد أصبت الهدف فى الدقائق الاخيرة

وتم التعديل مثلما أشرت حضرتك 

والحمد لله تعالى تم المطلوب

والشكر كل الشكر لاخوانى الافاضل

القدير الحاج / ابو خليل

القدير الحاج / احمد زمان

القديرالاستاذ المجتهد / ياسر العربى

لكم منى وافر التقدير والاحترام

 

تم تعديل نوفمبر 17, 2015 بواسطه ناصر المصرى