ترحيل بيانات العميل الى شيت اخر

[ابو نبأ]

السلام عليكم

سلمكم الله عندي سؤال ثاني بخصوص موضوعي السابق (تصفية حساب العميل ) الذي قام بحل الموضوع الأخ المبدع ياسر ابو براء حفظه الله وزاده علما 

سؤالي الثاني هو : ترحيل البيانات الموجودة بـ شيت تصفية حسابات العميل الى شيت اخر (ترحيل بيانات العميل)

وكما مبين بالمثال المرفق 

حفظكم الله وسلمكم من كل مكروه وطبعاً اكو سؤال ثالث ورابع ولكن بعد اكمال حل هذا السؤال وكما وجهه المنتدى ان يكون سؤال سؤال للفائدة 

السلام عليكم

 

تصفية حساب العميل + ترحيل.rar

تم تعديل أغسطس 28, 2015 بواسطه ابو نبأ
خطأ مطبعي

[ياسر خليل أبو البراء]

تفضل الكود التالي

قمت ببعض التعديلات على الكود الاول ليناسب الإضافة التي أضفتها

Sub TransferClientData()
    Dim WS As Worksheet, SH As Worksheet
    Dim LastRow As Long, LR As Long, I As Long
    Dim Arr

    Set WS = Sheets("تصفية حساب العميل"): Set SH = Sheets("ترحيل بيانات العميل")
    LastRow = WS.Cells(Rows.Count, "A").End(xlUp).Row - 3
    LR = SH.Cells(Rows.Count, "B").End(xlUp).Row + 1
    Arr = Array("B3", "E7", "B4", "A" & LastRow, "B" & LastRow, "C" & LastRow, "D3")

    With Application
        .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False
    End With
    
        If IsEmpty(Range("B3")) Or IsEmpty(Range("D3")) Or IsEmpty(Range("B4")) Or IsEmpty(Range("A6")) Then MsgBox "البيانات غير مكتملة", vbCritical: Exit Sub
        
        For I = 0 To UBound(Arr)
            SH.Cells(LR, I + 2) = WS.Range(Arr(I))
        Next
        SH.Cells(LR, 1) = SH.Cells(LR, 1).Row - 1

    With Application
        .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True
    End With
    
    MsgBox "تم ترحيل بيانات العميل بنجاح", 64
End Sub

 

Client Account Report YasserKhalil.rar

[ابو نبأ]

السلام عليكم

وفقكم الله - يرحم والديك - جزيت خيرا