نقل بيانات تلقائى من شيت لاخر

[moodyfy2]

اريد ترحيل تلقائى  للبيانات الموجودة فى ورقة 2 الى ورقة 1  بحيث يتم ترحيل الصفوف التى بها  المبلغ اكبر من صفر ووضعها اسفل بعض فى ورقة 1 وتجنب الصفوف التى بها المبلغ صفر

مثال.xlsx

[محمد هشام.]

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

في Module

Option Explicit
Sub Filtre()
    Dim tbl() As Variant, rng As Variant
    Dim desWS As Worksheet, WS As Worksheet
    Dim i As Long, j As Long, tmp As Long
    
    Set WS = Sheets("ورقة2")
    Set desWS = Sheets("ورقة1")
    
    Application.ScreenUpdating = False
    desWS.Range("A2:D" & desWS.Rows.Count).ClearContents
    
    rng = WS.Range("A2:D" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim tbl(1 To UBound(rng), 1 To UBound(rng, 2))
    
    For i = 1 To UBound(rng)
        If rng(i, 1) <> "" And rng(i, 4) > 0 Then
            tmp = tmp + 1
            For j = 1 To UBound(rng, 2)
                tbl(tmp, j) = rng(i, j)
            Next j
        End If
    Next i
    
    If tmp > 0 Then desWS.Range("A2").Resize(tmp, UBound(tbl, 2)).Value = tbl
    
    Application.ScreenUpdating = True
End Sub

وفي حدث ورقة1

Private Sub Worksheet_Activate()
  Call Filtre
End Sub

 

مثال.xlsm

[mahmoud nasr alhasany]

احسنت ا / محمد هشام

[moodyfy2]

الاستاذ محمد هشام

لك من كل التقدير والاحترام دائما لديك المعلومة المفيدة و سرعة الاستجابة

ادعو الله بدوام الصحة والعافية والتوفيق والنجاح من اخيك احمد سيد