Select and Paste Rows in a Different Location

Question

I am working with the output from a chemistry instrument, in .xls format.

The output contains up to seven blocks of data corresponding to different types of samples e.g. controls, unknowns, calibrators, etc... Each block is 15 columns by a variable number of rows, ranging from 3 to 15. The first row contains headers, the leftmost being "Name". The last row is denoted by a cell containing the string "Group Summaries".

My goal is to select the block of cells in between the header row and last row, for each of the seven sample types (R1 to R7). After selecting the blocks I want to join them together (MultiRange) and paste in a different location (not yet decided).

I have written a Sub to accomplish this task however it is super duper repetitive and I would like to know how to shorten it up by creating some sort of loop.

Sub ConsolidateRanges()

Dim R1 As Range, R2 As Range, R3 As Range, R4 As Range, R5 As Range, R6 As Range, R7 As Range, MultiRange As Range
Dim StartRow As Integer, EndRow As Integer

'Selection for Negative Control
Cells.Find(What:="Name", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

StartRow = ActiveCell.Row + 1

Cells.Find(What:="Group Summaries", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

EndRow = ActiveCell.Row - 1

Range("A" & StartRow, "O" & EndRow).Select

Set R1 = Selection

'Selection for Positive Control
Cells.Find(What:="Name", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

StartRow = ActiveCell.Row + 1

Cells.Find(What:="Group Summaries", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

EndRow = ActiveCell.Row - 1

Range("A" & StartRow, "O" & EndRow).Select

Set R2 = Selection

'Selection for Calibrator
Cells.Find(What:="Name", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

StartRow = ActiveCell.Row + 1

Cells.Find(What:="Group Summaries", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

EndRow = ActiveCell.Row - 1

Range("A" & StartRow, "O" & EndRow).Select

Set R3 = Selection

'Selection for Unknown
Cells.Find(What:="Name", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

StartRow = ActiveCell.Row + 1

Cells.Find(What:="Group Summaries", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

EndRow = ActiveCell.Row - 1

Range("A" & StartRow, "O" & EndRow).Select

Set R4 = Selection

'Selection for Unknown blank
Cells.Find(What:="Name", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

StartRow = ActiveCell.Row + 1

Cells.Find(What:="Group Summaries", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

EndRow = ActiveCell.Row - 1

Range("A" & StartRow, "O" & EndRow).Select

Set R5 = Selection

'Selection for QC
Cells.Find(What:="Name", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

StartRow = ActiveCell.Row + 1

Cells.Find(What:="Group Summaries", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

EndRow = ActiveCell.Row - 1

Range("A" & StartRow, "O" & EndRow).Select

Set R6 = Selection

'Selection for QC blank
Cells.Find(What:="Name", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

StartRow = ActiveCell.Row + 1

Cells.Find(What:="Group Summaries", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

EndRow = ActiveCell.Row - 1

Range("A" & StartRow, "O" & EndRow).Select

Set R7 = Selection

'Now merge it all together
Set MultiRange = Union(R1, R2, R3, R4, R5, R6, R7)
MultiRange.Select
Selection.Copy
End Sub

---

This is what the instrument output looks like. The blocks that I want to copy and paste elsewhere are highlighted in green. Each block of data has a row of headers above, and a row with the text "Group Summaries" below.

Answer 1

Looking at the screenshot you just added was very helpful!

For the task I'd suggest code similar to this:

Main functions:

Option Explicit

Private Const DATA_WS As String = "BLOCK "  'Name of Worksheets containing data

Public Sub main()
    distributeData Sheet1
End Sub

Public Sub distributeData(ByRef ws As Worksheet)

    Const BLOCK_START   As String = "Name"
    Const BLOCK_END     As String = "Group Summaries"
    Const ID            As Long = 1

    Dim idArr       As Variant
    Dim aRow        As Long
    Dim aWS         As Long
    Dim itms        As Long
    Dim lastCel     As Range
    Dim lastRow     As Long
    Dim lastCol     As Long
    Dim wsData      As Worksheet
    Dim headers     As Range

    Set lastCel = getMaxCell(ws.UsedRange)  'determine used range

    If lastCel.Row > 1 Then          'if the sheet is not empty start the loop

        Application.ScreenUpdating = False

        idArr = ws.UsedRange.Columns(ID)    'get search column in memory
        removePreviousDataSheets

        With lastCel
            lastRow = .Row
            lastCol = .Column
        End With

        aWS = 1 'new worksheet 1

        For aRow = 1 To lastRow     'for each row in column 1

            If idArr(aRow, 1) = BLOCK_START Then

                'get headers for current block
                Set headers = ws.Range(ws.Cells(aRow, ID), ws.Cells(aRow, lastCol))

                itms = aRow + 1
                While idArr(itms, 1) <> BLOCK_END
                    itms = itms + 1                 'count all items in current block
                Wend
                itms = itms - 1

                'make a new worksheet
                With Worksheets
                    Set wsData = .Add(, Worksheets(.Count), 1, xlWorksheet)
                End With

                With wsData
                   .Name = DATA_WS & aWS

                   'copy headers
                   headers.Copy
                   .Range(.Cells(1, ID), .Cells(1, lastCol)).PasteSpecial xlPasteAll

                   'and data for current block
                   ws.Range(ws.Cells(aRow + 1, ID), ws.Cells(itms, lastCol)).Copy
                   .Range(.Cells(2, ID), .Cells(itms - aRow + 1, lastCol)).PasteSpecial

                    .Cells(1, 1).Activate
                End With
                aWS = aWS + 1
                aRow = itms + 1 'will be incremented by 2 because of the FOR loop
            End If
        Next

        ws.Activate
        ws.Cells(1, 1).Activate

        With Application
            .CutCopyMode = False
            .ScreenUpdating = True
        End With

    End If
End Sub

Helper function: determine last cell of data on the sheet

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range

    'Returns the last cell containing a value, or A1 if Worksheet is empty

    Const NONEMPTY As String = "*"
    Dim lRow As Range, lCol As Range

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
    If WorksheetFunction.CountA(rng) = 0 Then
        Set GetMaxCell = rng.Parent.Cells(1, 1)
    Else
        With rng
            Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                        After:=.Cells(1, 1), _
                                        SearchDirection:=xlPrevious, _
                                        SearchOrder:=xlByRows)
            If Not lRow Is Nothing Then
                Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                            After:=.Cells(1, 1), _
                                            SearchDirection:=xlPrevious, _
                                            SearchOrder:=xlByColumns)
                Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
            End If
        End With
    End If
End Function

Helper function: removes previous data sheets

Private Sub removePreviousDataSheets()

    Dim dataWS As Worksheet

    Application.DisplayAlerts = False   'turn off Excel warning
    For Each dataWS In Worksheets
        With dataWS
            If InStr(1, .Name, DATA_WS, vbTextCompare) > 0 Then .Delete
        End With
    Next
    Application.DisplayAlerts = True    'turn Excel warnings back on
End Sub

Test file - Main sheet:

Result - Separate sheets:

Answer 2

Super duper repetitive is an understatement!

Every time you select a code block and press Ctrl+C, stop and think twice before you click anywhere else and hit Ctrl+V: copy-pasta code rarely makes anything other than a mess you'll be sorry you have to maintain later on... if you're the one maintaining it. If not, I hope the person that inherits this code isn't a violent psychopath that knows where you live! ;-)

Always code as if the guy who ends up maintaining your code will be a violent psychopath who knows where you live. Code for readability.

_{https://stackoverflow.com/a/878436/1188513}

---

What should happen between your ears when you stop and think twice, is a thought process that goes something like:

How can I avoid duplicating this logic all over the place, write it only once and pass in different parameter values every time I need it?

In this case, it looks like this is your selection when you copy:

StartRow = ActiveCell.Row + 1

Cells.Find(What:="Group Summaries", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate

EndRow = ActiveCell.Row - 1

Range("A" & StartRow, "O" & EndRow).Select

Set R1 = Selection

Each block is assigning some Rn value, where n is a number between 1 and the number of ranges you end up merging. What's that smell? Of course you guessed right, you need looping logic!

You're going to extract a Function from that code block, take your search string as a parameter, and make it return a Range object.

Private Function FindNextBlock(ByVal searchValue As String) As Range

    StartRow = ActiveCell.Row + 1

    Dim searchResult As Range
    Set searchResult = target.Cells.Find(What:=searchValue, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
    :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False)

    If searchResult Is Nothing Then Exit Function

    searchResult.Activate
    EndRow = ActiveCell.Row - 1

    Range("A" & StartRow, "O" & EndRow).Select

    Set FindNextBlock = Selection

End Function

I've extracted and assigned a searchResult object variable here, because you have a runtime error 91 (object or with block variable not set) waiting to happen, if the .Find call doesn't find anything. Returning immediately makes the function return Nothing, and the caller can deal with that later.

The caller might be doing something like this at this point:

FindNextBlock("Name")
Set R1 = FindNextBlock("Group Summaries")
Set R2 = FindNextBlock("Name")
Set R3 = FindNextBlock("Group Summaries")
Set R4 = FindNextBlock("Name")
Set R5 = FindNextBlock("Group Summaries")
Set R6 = FindNextBlock("Name")
Set R7 = FindNextBlock("Group Summaries")
Set MultiRange = Union(R1, R2, R3, R4, R5, R6, R7)

...and that's still not it. Everything relies on the initial ActiveCell! That's not a reasonable assumption to make - and that's exactly why working with Selection and ActiveCell (and ActiveSheet) is a major problem. Add another parameter to your function, ByRef currentLocation As Range, and reassign that reference at each call, passing the modified reference to each successive call - and the initial call can take a Range you have complete control over.

That fixes another bug, but doesn't make any loops. The problem is that Union doesn't take an array or a Collection of ranges - it takes ranges that have to be specified one after the other. In other words, you're kinda stuck there.

In an ideal world, you could do this:

Dim currentLocation As Range
Set currentLocation = ActiveCell 'todo: change that

Dim blocks(1 To 8) As String
blocks(1) = "Name"
blocks(2) = "Group Summaries"
blocks(3) = "Name"
blocks(4) = "Group Summaries"
blocks(5) = "Name"
blocks(6) = "Group Summaries"
blocks(7) = "Name"
blocks(8) = "Group Summaries"

For i = 1 To 8
    Set result = FindNextBlock(blocks(i), currentLocation)
    If i > 1 And result Is Not Null Then myRanges.Add result
Next

Set multiRange = Union(myRanges) 'nope

Instead of union-ing them and copying and pasting them all at once, you could have the copy+paste operation as part of the loop. And then there's more abstractions to make - I don't like that array, and I don't like skipping the first one (seems arbitrary)... but that's already way too far from the code you've got here.