نقل بيانات من ورقة عمل لأخرى بدون اصفار

[ِAhmed mahmoud a]

بعد اذن السادة الأعضاء التفضل بمساعدتى فى نقل بيانات الملف المرفق من ورقة عمل لأخرى  بدون الحسابات التى ليس بها اى قيم على مستوى اجمالى الفترات

Budget 2023.xlsb

[أبو إيمان]

صيانة عدد وادوات صغيرة يوجد صفر في العمود يناير وفبراير  هل تريد نقلها   --- نفقات دعاية واعلان يوجد قيمة في يناير فقط 

نفقات دعاية العلامه التجاريه لا يوجد قيم 

أي منهم تريد الحذف وأي منهم تريد الابقاء عليه

[ِAhmed mahmoud a]

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

[أبو إيمان]

تفضل كود بطريقة بدائية ربما تفيد إن شاء الله ولعل الأساتذة لديهم أفضل من ذلك 

Budget 2023.xlsb

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

بالاذن خيار آخر

Sub test()
Dim a, b
Dim i&, ii&, c&
With Sheets("Budget 2023")
a = .Cells(2, 3).Resize(.Cells(Rows.Count, 3).End(xlUp).Row, .Cells(3, Columns.Count).End(xlToLeft).Column)
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
End With
c = 1
For i = 1 To UBound(a)
    If Application.Sum(Application.Index(a, i, Evaluate("row(4" & ":" & UBound(a, 2) - 3 & ")"))) <> 0 Then
        For ii = 1 To UBound(a, 2)
            b(c, ii) = a(i, ii)
        Next
c = c + 1
    End If
Next
Sheets("بعد التصفية").Cells(2, 3).Resize(c, UBound(b, 2)) = b
End Sub

 

[محمد هشام.]

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

بعد ادن الاخوة الكرام اليك حل اخر على حسب ما فهمت من طلبك وهو نسخ الصفوف بشرط عدم وجود قيمة صفرية في جميع الخلايا  من العمود F الى N

Sub CopyData()
Dim x, i As Long, j As Long, MH As Long, n As Long
Dim st As Worksheet, WS As Worksheet, s As String
   Application.ScreenUpdating = False
   Set st = Sheets("Budget 2023")
   MH = st.Range("D" & Rows.Count).End(xlUp).Row
   x = st.Range("D1:N" & MH)
   ReDim Preserve x(1 To UBound(x), 1 To UBound(x, 2) + 1)
   For i = 1 To UBound(x)
      For j = 3 To UBound(x, 2) - 1: x(i, UBound(x, 2)) = x(i, UBound(x, 2)) & x(i, j): Next j
   Next i
   Set WS = Sheets("résultat")
   WS.Range("A:K").ClearContents
   For i = 1 To UBound(x)
      If x(i, UBound(x, 2)) <> 0 Then
 
         n = n + 1
         For j = 1 To UBound(x, 2): x(n, j) = x(i, j): Next
      End If
   Next
   
   With WS.Range("A1").Resize(n, UBound(x, 2) - 1)
      .Value = x
      .HorizontalAlignment = xlCenter
      '.BorMHs.LineStyle = xlContinuous
   End With
End Sub

 

Budget 2023_v1.xlsb