Excel VBA-如何在空白單元格之后復制和粘貼數據組？

Question

我在B6和M6中有彼此直接對應的數據。 數據來自B6：B12，然后B13：B14中有兩個空白單元格。 然后，數據從B15：B23繼續，然后有兩個空白單元格，並且該模式在頁面下重復...（M列也是如此）。

我研究發現空白單元格，並能夠使用此代碼從B6：B12和M6：M12抓取第一組數據並將其粘貼到所需位置的新工作表中。 這是代碼：

Sub CopyandPaste()

NextFree = Range("B6:B" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("B" & NextFree).Select

NextFree2 = Range("M6:M" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("M" & NextFree2).Select

Sheets("Sheet 1").Range("B6:B" & NextFree).Copy Destination:=Sheets("Sheet 2").Range("B13")

Sheets("Sheet 1").Range("M6:M" & NextFree2).Copy Destination:=Sheets("Sheet 2").Range("J13")

End Sub

這可以搶先在兩個空白單元格之前將第一個組捕獲，但是我無法找到一種方法來搶奪在兩個空白單元格之后的第二個，第三個組等等。 任何幫助，將不勝感激。

Answer 1

如果您知道塊的模式（塊-2個空格-塊），則可以進行嵌套循環。

Sub grabBlocks()

Dim cFirst As Range, cLast As Range
Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets(1)
Set cFirst = sh.Range("B6") 'First Cell of each new block
Set cLast = cFirst 'This becomes last cell of the block

Do While Not cFirst = ""

    'Get Last Cell of Block
    Do While Not cLast.Offset(1, 0) = ""
        Set cLast = cLast.Offset(1, 0)
    Loop

    'Do copy with this address
    Debug.Print Range(cFirst.Address & ":" & cLast.Address).Address
    '... copy code goes here...

    'Go to next block
    Set cFirst = cLast.Offset(3, 0) 'First cell of new block is 2 + 1 cells below the last
    Set cLast = cFirst
Loop

End Sub

當下一個區塊距離超過2個像元時，此代碼將終止，並期望不再有其他區塊出現。

請注意，如果無法滿足終止條件（例如，單元格包含“不可見”數據（例如空格）），這些循環可能會變得很討厭

Answer 2

Sub copynPaste()
Dim i As Integer, j As Integer
j = 1
   'loops from 1 to the last filled cell in column 2 or "B"
    For i = 1 To Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
       'checks if the cell has anything in it
        If IsEmpty(Sheets("Sheet1").Range("B" & i)) = False Then
            'this is where the copying and pasting happens (well basically)
            Sheets("Sheet2").Range("B" & j).Value = Sheets("Sheet1").Range("B" & i).Value
            Sheets("Sheet2").Range("M" & j).Value = Sheets("Sheet1").Range("M" & i).Value
            j = j + 1
        End If
    Next i
End Sub