Sub test()
Dim lr, r, x
r = 4
With Sheets(1)
.Range("d4:e10000").ClearContents
lr = .Cells(Rows.Count, "k").End(3).Row
   For x = 4 To lr
   If .Cells(x, "k") = 0 Then GoTo 1
   .Range("d" & r).Resize(1, 2).Value = .Cells(x, "k").Resize(1, 2).Value
   r = r + 1
1:   Next x
End With
End Sub

Sub Test()
    With Sheets(1).Range("K3").CurrentRegion
        .AutoFilter 1, "<>0"
        .Copy Sheets(1).Range("D3")
        .AutoFilter
    End With
End Sub

Option Explicit

Sub without_zeros()
Dim Source_Array As Variant
Dim Target_Array()
Dim n%, i%
    With Sheets("ورقة1")
      .Range("D3").CurrentRegion.ClearContents
       Source_Array = .Range("K3").CurrentRegion
       
       For i = 1 To UBound(Source_Array)
          If Source_Array(i, 1) <> 0 Then
             n = n + 1
             ReDim Preserve Target_Array(1 To 2, 1 To n)
             Target_Array(1, n) = Source_Array(i, 1)
             Target_Array(2, n) = Source_Array(i, 2)
           End If
        Next i
          
          If n Then
            .Range("D3").Resize(n, 2) = _
             Application.Transpose(Target_Array)
          End If
    End With
End Sub

المشاركة الأصلية كتبت بواسطة: salim زيادة في اثراء الموضوع

CODE

 Option Explicit Sub without_zeros() Dim Source_Array As Variant Dim Target_Array() Dim n%, i%     With Sheets("ورقة1")       .Range("D3").CurrentRegion.ClearContents        Source_Array = .Range("K3").CurrentRegion                For i = 1 To UBound(Source_Array)           If Source_Array(i, 1) <> 0 Then              n = n + 1              ReDim Preserve Target_Array(1 To 2, 1 To n)              Target_Array(1, n) = Source_Array(i, 1)              Target_Array(2, n) = Source_Array(i, 2)            End If         Next i                      If n Then             .Range("D3").Resize(n, 2) = _              Application.Transpose(Target_Array)           End If     End With End Sub 

Option Explicit

Sub without_zeros()
Dim Source_Array As Variant
Dim Target_Array()
Dim n%, i%
    With Sheets("ورقة1")
       Source_Array = .Range("K3").CurrentRegion
      .Range("D3").Resize(UBound(Source_Array), 2).Clear
       For i = 1 To UBound(Source_Array)
          If Source_Array(i, 1) <> 0 Then
             n = n + 1
             ReDim Preserve Target_Array(1 To 2, 1 To n)
             Target_Array(1, n) = Source_Array(i, 1)
             Target_Array(2, n) = Source_Array(i, 2)
           End If
        Next i
          
          If n Then
            .Range("D3").Resize(n, 2) = _
             Application.Transpose(Target_Array)
                 
           .Range("K3").CurrentRegion.Copy
           .Range("D3").Resize(n, 2).PasteSpecial 4
           Application.CutCopyMode = False
          .Range("D3").Select
       End If
    End With
End Sub

المشاركة الأصلية كتبت بواسطة: salim استبدل الكود بهذا

CODE

 Option Explicit Sub without_zeros() Dim Source_Array As Variant Dim Target_Array() Dim n%, i%     With Sheets("ورقة1")        Source_Array = .Range("K3").CurrentRegion       .Range("D3").Resize(UBound(Source_Array), 2).Clear        For i = 1 To UBound(Source_Array)           If Source_Array(i, 1) <> 0 Then              n = n + 1              ReDim Preserve Target_Array(1 To 2, 1 To n)              Target_Array(1, n) = Source_Array(i, 1)              Target_Array(2, n) = Source_Array(i, 2)            End If         Next i                      If n Then             .Range("D3").Resize(n, 2) = _              Application.Transpose(Target_Array)                              .Range("K3").CurrentRegion.Copy            .Range("D3").Resize(n, 2).PasteSpecial 4            Application.CutCopyMode = False           .Range("D3").Select        End If     End With End Sub 

الملف مرفق

Sub Test()
    With Sheets(1)
        .Range("D3").CurrentRegion.Clear
        With .Range("K3").CurrentRegion
            .AutoFilter 1, "<>0"
            .Copy .Parent.Range("D3")
            .AutoFilter
        End With
    End With
End Sub