VBA Excel-以正確的順序將列放入范圍

Question

所以最近我一直在研究使用定義的范圍來復制數據，而不是選擇，復制和粘貼單元格。 通過這種方式，我希望優化代碼的性能和運行時間。

不幸的是，我遇到了一個我自己無法解決的問題。

定義范圍時，我想以不同的順序重新排列列。

例如：

Set my_range = Sheets("Sheet1").Range("A2:E2,G2:H2,J2:K2,M2")

效果很好，因為我填充到范圍中的列在工作表中彼此靠后。 但是現在我有了這個：

Set yo_range = Sheets("Sheet2").Range("D2,AV2,L2,H2,Q2,AE2,AG2")

如果我將這些范圍填充到新的工作表中，則yo_range將填充我放入其中的列，但不填充我寫下的順序。 它將按照原始順序將其放下。 在此示例中， yo_range會將數據按此順序放入新表中：

D2 | H2 | L2 | Q2 | AE2 | AG2 | AV2

我怎樣才能解決這個問題？ 我希望該訂單與原始訂單不同。 另外-如您所見， my_range的列多於yo_range 。 如何讓yo_range填充到新表中，但在某些時候將列留在外面？ 例如：

my_range（A2：E2）進入新表的A2：E2

yo_range（D2，AV2）進入新表中的A：B，然后將C留在外面，然后將yo_range（L2，H2）粘貼到新表中的D：E中

我希望我能夠很好地解釋我的問題，並且希望有人能夠並且願意幫助我。 任何幫助表示贊賞。

編輯：

這是將范圍中的值放入新表的代碼

Do
    If Application.WorksheetFunction.CountA(my_range) > 0 Then
    my_range.Copy ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0)
    Set my_range = my_range.Offset(1, 0)
    Else
    Exit Do
    End If
Loop


Do
    If Application.WorksheetFunction.CountA(yo_range) > 0 Then
    yo_range.Copy ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0)
    Set yo_range = yo_range.Offset(1, 0)
    Else
    Exit Do
    End If
Loop

Answer 1

我們可以看到， Copy方法將按從左到右的順序重新排列數據。 嘗試這個：

Option Explicit

Public Sub CheckClipboard()

    Dim ws As Worksheet
    Dim rngToCopy As Range
    Dim objData As Object
    Dim varContents As Variant

    ' test data b,c,d,e,f,g in Sheet1!B1:G1
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ws.Range("B1:G1").Value = Array("b", "c", "d", "e", "f", "g")

    Set rngToCopy = ws.Range("E1:F1,G1,B1:C1") '<-- note not left-to-right order
    rngToCopy.Copy '<-- copy

    ' this is a late bound MSForms.DataObject
    Set objData = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

    ' copy current cell formula to clipboard
    objData.GetFromClipboard
    varContents = objData.GetText

    Debug.Print varContents '<-- re-arranged left-to-right

    ' cancel copy
    Application.CutCopyMode = False

End Sub

我在即時窗口中得到這個：

b   c   d   e   f   g

因此，使用“ Copy無法滿足您的需求。

為了“粘貼”在您設置的順序數據Range ，你需要遍歷每個Area的的Range ，然后將每個小區（即Range在每個） Area 。 請參閱下面的測試代碼，它可以復制您的問題並提出解決方案：

Option Explicit

Sub MixColumns()

    Dim ws As Worksheet
    Dim rngIn As Range
    Dim rngOut As Range
    Dim lng As Long
    Dim rngArea As Range
    Dim rngCell As Range

    Set ws = ThisWorkbook.Worksheets("Sheet1")

    ' example 1
    Set rngIn = ws.Range("B1:C1,E1:F1,G1") '<-- 5 cells, non-contiguous, forward order
    Set rngOut = ws.Range("B2:F2") '<-- 5 contiguous cells

    rngIn.Copy rngOut '<-- works


    ' example 2 - OP problem
    Set rngIn = ws.Range("E1:F1,G1,B1:C1") '<-- 5 cells, non-contiguous, odd order
    Set rngOut = ws.Range("B3:F3") '<-- 5 contiguous cells

    rngIn.Copy rngOut '<-- should be e,f,g,b,c but gets b,c,e,f,g


    ' example 3 - solution for OP problem
    Set rngIn = ws.Range("E1:F1,G1,B1:C1") '<-- 5 cells, non-contiguous, odd order
    Set rngOut = ws.Range("B4:F4") '<-- 5 contiguous cells

    lng = 1 '<-- rngOut cell counter
    ' iterate areas
    For Each rngArea In rngIn.Areas
        ' iterate cells in area
        For Each rngCell In rngArea.Cells
            rngOut.Cells(1, lng).Value = rngCell.Value '<-- copy single value
            lng = lng + 1 '<-- increment rngOut counter
        Next rngCell
    Next rngArea '<-- results in e,f,g,b,c


End Sub

給出以下輸出：