مطلوب كود ترحيل من صفحة BON الى الارشيف ( عنوان معدل )

[ابو محمد نصري]

مساعده من خبراء الاكسيل
كود ترحيل من صفحة BON الى الارشيف

BONتعديل.rar

[طارق محمود]

السلام عليكم

أخي العزيز

تفضل المرفق وبه كود لعمل المطلوب

 

الكود هو

Sub Tarheel()
LR = [A58].End(xlUp).Row
If LR < 20 Then MsgBox "No data to shift": Exit Sub


nm = [B11]: dt = [B17]
Set Q_P = Union(Range("A20:A" & LR), Range("E20:E" & LR))
Set dsc = Range("B20:B" & LR)
n = dsc.Count


Sheets("الارشف").Activate
nr = [B9999].End(xlUp).Row + 1
dsc.Copy
    Cells(nr, 4).PasteSpecial Paste:=xlPasteValues
Q_P.Copy
    Cells(nr, 5).PasteSpecial Paste:=xlPasteValues
Range("B" & nr & ":B" & nr + n - 1) = dt
Range("C" & nr & ":C" & nr + n - 1) = nm
End Sub

ويتم تفعيله بالضغط علي زر ترحيل 

BON.rar

[ابو محمد نصري]

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

BON1.rar

[طارق محمود]

السلام عليكم

أخي العزيز

تفضل المرفق وبه تعديل الكود 

 

لاحظت أنك أضفت أعمدة في ورقة الأرشيف

وقد عدلت الكود أيضا ليناسب أرقام الأعمدة الجديدة

تذكر أن الكود تم تفصيله علي هذا الشكل

ولايجوز إضافة مثل هذه الأعمدة ، إلا إذا كنت تستطيع التعديل علي الكود

 

الكود الجديد

Sub Tarheel()
LR = [A58].End(xlUp).Row
If LR < 20 Then MsgBox "No data to shift": Exit Sub


nm = [B11]: dt = [B17]: bil = [K11]
Set Q_P = Union(Range("A20:A" & LR), Range("E20:E" & LR))
Set dsc = Range("B20:B" & LR)
n = dsc.Count


Sheets("الارشف").Activate
    nr = [E9999].End(xlUp).Row + 1
    dsc.Copy
        Cells(nr, 7).PasteSpecial Paste:=xlPasteValues
    Q_P.Copy
        Cells(nr, 8).PasteSpecial Paste:=xlPasteValues
    Range("E" & nr & ":E" & nr + n - 1) = dt
    Range("F" & nr & ":F" & nr + n - 1) = nm
    Range("D" & nr & ":D" & nr + n - 1) = bil


Sheets("bon de livraison ").Activate
    Set dsc = dsc.Resize(n, 3)
    dsc.Select
    dsc.ClearContents
    [B11:C11].ClearContents
    [B17].ClearContents
    Q_P.ClearContents
    [K11] = [K11] + 1
End Sub

هل لاحظت مثلا أن 

Sheets("الارشف").Activate
nr = [B9999].End(xlUp).Row + 1
dsc.Copy
    Cells(nr, 4).PasteSpecial Paste:=xlPasteValues
Q_P.Copy
    Cells(nr, 5).PasteSpecial Paste:=xlPasteValues
Range("B" & nr & ":B" & nr + n - 1) = dt
Range("C" & nr & ":C" & nr + n - 1) = nm

 

 

أصبحت

Sheets("الارشف").Activate

    nr = [E9999].End(xlUp).Row + 1
    dsc.Copy
        Cells(nr, 7).PasteSpecial Paste:=xlPasteValues
    Q_P.Copy
        Cells(nr, 8).PasteSpecial Paste:=xlPasteValues
    Range("E" & nr & ":E" & nr + n - 1) = dt
    Range("F" & nr & ":F" & nr + n - 1) = nm

BON1.rar

[ابو محمد نصري]

اخي استاذ طارق جزاك الله كل خير وجعله في ميزان حسناتك 

ممكن لو سمحت كود نقل البيانات من الارشيف الى كشف الحساب العميل 

BON2.rar

تم تعديل مارس 19, 2015 بواسطه tarekchahine

[ابو محمد نصري]

استغفر الله العظيم الذي لااله الاهو الحي القيوم واتوب اليه

[طارق محمود]

السلام عليكم

تفضل اخي

غير إسم العميل (في ورقة كشف حساب) وسيتم فرز بياناته من ورقة الأرشيف أوتوماتيكيا

 

BON3.rar

[ابو محمد نصري]

شكرا لك استاذ ولكن في نقل البيانات تكون العمليه ثقيل وبطيئ

BON4.rar

تم تعديل مارس 19, 2015 بواسطه tarekchahine

[ابو محمد نصري]

استغفر الله العظيم الذي لااله الاهو الحي القيوم واتوب اليه

[طارق محمود]

تكون العمليه في نقل البيانات ثقيلة وبطيئة لأن ورقة الأرشيف بها 10 آلاف بيان

مرفق الملف مرة أخري وبه ربط لكودي الإظهار والاخفاء

BON4.rar

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

أستاذي الكبير طارق محمود

اسمح لي بهذه المشاركة

جرب الكود التالي :

Sub CopyFilter()
    Dim rng As Range
    Dim rng2 As Range
    
    Dim WS As Worksheet, SH As Worksheet
    Set WS = Sheets("الارشف"): Set SH = Sheets("كشف حساب")
    
    WS.Range("C4:O" & WS.Cells(Rows.Count, 5).End(xlUp).Row).AutoFilter Field:=4, Criteria1:=SH.Range("F3")
    
    With WS.AutoFilter.Range
     On Error Resume Next
       Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
     On Error GoTo 0
    End With
    If rng2 Is Nothing Then
       MsgBox "لا يوجد بيات للنسخ"
    Else
       SH.Range("C6:N10000").Clear
       Set rng = WS.AutoFilter.Range
       rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy Destination:=SH.Range("C6")
    End If
       WS.ShowAllData

End Sub

[ابو محمد نصري]

اخي استاذ طارق و استاذ ياسر جزاكم الله كل خير وجعله في ميزان حسناتك

ممكن كود اهتزاز شاشه في صفحه bon و صفحه كشف الحساب

BON44.rar