نقل بيانات بين عمودين بدون الخلايا الفارغة وبنفس التنسيق

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

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