從非連續單元格復制數據

Question

我想自動將數據從一個非連續范圍復制到另一個范圍。 源和目標具有相同數量的單元格，但范圍形狀不同。 下面是一個簡化的圖形來演示。

數據的簡化：

源數據位於單個列中，並且不連續。 目標范圍是將存儲的數據復制到儀表板的位置。

所有建議表示贊賞。

Answer 1

將非連續范圍復制到另一個非連續范圍

• 調整常量部分中的值。

Option Explicit

Sub CopyNonContiguous()
    
    ' Constants
    
    ' Source
    Const sName As String = "Sheet1"
    Const sAddress As String = "G3:G6,G8:G15"
    ' Destination
    Const dName As String = "Sheet1"
    Const dAddress As String = "B3:B4,B6:B7,B9:E10"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Destination Range
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim drg As Range: Set drg = dws.Range(dAddress)
    'drg.Interior.Color = 14348258 ' green
    
    ' Source Range
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range(sAddress)
    'srg.Interior.Color = 13431551 ' yellow
    
    ' Source Data Array
    
    Dim scCount As Long: scCount = srg.Cells.Count
    Dim sData As Variant: ReDim sData(1 To scCount)
    
    ' Additional Variables
    
    Dim arg As Range ' Current Range Area
    Dim cel As Range ' Current Cell in Current Range Area
    Dim n As Long ' Source Data Array Elements Counter
    
    ' Source Range to Source Data Array
    
    For Each arg In srg.Areas
        For Each cel In arg.Cells
            n = n + 1
            'cel.Value = n ' to populate the Source Range
            sData(n) = cel.Value
        Next cel
    Next arg
    
    ' Source Data Array to Destination Range
    
    ' Reset 'n' because at this moment 'n = scCount'.
    n = 0
    For Each arg In drg.Areas
        For Each cel In arg.Cells
            n = n + 1
            cel.Value = sData(n)
            ' Since the Destination Range could contain more cells than
            ' the Source Range, test with the following:
            If n = scCount Then Exit Sub
        Next cel
    Next arg
    
End Sub

Answer 2

您可以“記錄宏”，然后將您想要的所有字段復制到正確的位置？

記錄的代碼如下所示：

Sub Macro1()
'
' Macro1 Macro
'

'
    Range("G3:G4").Select
    Selection.Copy
    Range("B3").Select
    ActiveSheet.Paste
    Range("G5:G6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("B6").Select
    ActiveSheet.Paste
    Range("G8:G11").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("B9").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("G12:G15").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("B10").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("B12").Select
End Sub

編輯：沒有Select它可能看起來像這樣：

Sub macro2()
    Dim a As Worksheet
    Set a = ActiveSheet
    
    a.Range("G3:G4").Copy Destination:=a.Range("B3")
    a.Range("G5:G6").Copy Destination:=a.Range("B6")
    
    a.Range("B9:E9") = Application.WorksheetFunction.Transpose(a.Range("G8:G111"))
    a.Range("B10:E10") = Application.WorksheetFunction.Transpose(a.Range("G12:G15"))
    
End Sub