نسخ و لصق جدول معكوسا

Option Explicit



Sub test()

Dim firstX, lastX

Dim Y

Y = 10

firstX = 6

Application.ScreenUpdating = False

Do

If Y = 14 Then Exit Sub

Cells(firstX, "c").Resize(, 8).Copy

Range("c" & Y).PasteSpecial

Application.CutCopyMode = False



firstX = firstX - 1

Y = Y + 1

Loop

Application.ScreenUpdating = True



End Sub

Sub Test()

    Dim a, e, v, x, rng As Range, i As Long, ii As Long

    Set rng = Range("B2:J6")

    rng.Copy Range("B23")

    With Range("B23")

        .Resize(rng.Rows.Count, 5).NumberFormat = "@"

        .Offset(, 5).Resize(rng.Rows.Count, 5).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"

        a = .CurrentRegion.Value

    End With

    For i = LBound(a) To UBound(a)

        For Each e In Array(Array(2, 3, 4, 5), Array(6, 7, 8, 9))

            x = Application.Index(a, i, e)

            v = ReverseArray(x)

            If UBound(v) > 0 Then

                For ii = LBound(v) To UBound(v)

                    a(i, ii + e(0)) = v(ii)

                Next ii

            End If

        Next e

    Next i

    With Range("B23")

        .Resize(UBound(a, 1), UBound(a, 2)).Value = a

    End With

End Sub



Function ReverseArray(ByVal arr)

    Dim v

    With CreateObject("System.Collections.ArrayList")

        For Each v In arr

            If v <> Empty Then .Add v

        Next v

        .Reverse

        ReverseArray = .Toarray

    End With

End Function