Excel VBA-如何在空白单元格之后复制和粘贴数据组？

Question

I have data in B6 and M6 that correspond directly with each other. The data goes from B6:B12 and then there are two blank cells in B13:B14. The data then goes on from B15:B23 and then there are two blank cells and this pattern repeats down the page...(the same goes for column M).

I researched finding blank cells and was able to use this code to grab that first set of data from B6:B12 and M6:M12 and paste it on to a new worksheet in the location I wanted. Here is the code:

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

This works to grab the first group before the blank the two blank cells but I cannot find a way to grab the second, third, and so on groups that follow two blank cells. Any help would be appreciated.

Answer 1

If you know the pattern of blocks (block - 2 spaces - block) you can do a nested loop.

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

This code will terminate when the next block is more than 2 cells away, expecting no more blocks to come.

Beware that these loops can become nasty if your termination condition can not be satisfied (eg your cells contain 'invisible' data like spaces)

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