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 RangeDim StartRow As Integer, EndRow As Integer'Selection for Negative ControlCells.Find(What:=Name, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateStartRow = ActiveCell.Row + 1Cells.Find(What:=Group Summaries, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateEndRow = ActiveCell.Row - 1Range(A & StartRow, O & EndRow).SelectSet R1 = Selection'Selection for Positive ControlCells.Find(What:=Name, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateStartRow = ActiveCell.Row + 1Cells.Find(What:=Group Summaries, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateEndRow = ActiveCell.Row - 1Range(A & StartRow, O & EndRow).SelectSet R2 = Selection'Selection for CalibratorCells.Find(What:=Name, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateStartRow = ActiveCell.Row + 1Cells.Find(What:=Group Summaries, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateEndRow = ActiveCell.Row - 1Range(A & StartRow, O & EndRow).SelectSet R3 = Selection'Selection for UnknownCells.Find(What:=Name, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateStartRow = ActiveCell.Row + 1Cells.Find(What:=Group Summaries, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateEndRow = ActiveCell.Row - 1Range(A & StartRow, O & EndRow).SelectSet R4 = Selection'Selection for Unknown blankCells.Find(What:=Name, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateStartRow = ActiveCell.Row + 1Cells.Find(What:=Group Summaries, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateEndRow = ActiveCell.Row - 1Range(A & StartRow, O & EndRow).SelectSet R5 = Selection'Selection for QCCells.Find(What:=Name, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateStartRow = ActiveCell.Row + 1Cells.Find(What:=Group Summaries, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateEndRow = ActiveCell.Row - 1Range(A & StartRow, O & EndRow).SelectSet R6 = Selection'Selection for QC blankCells.Find(What:=Name, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateStartRow = ActiveCell.Row + 1Cells.Find(What:=Group Summaries, After:=ActiveCell, LookIn:=xlFormulas, LookAt _:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _False, SearchFormat:=False).ActivateEndRow = ActiveCell.Row - 1Range(A & StartRow, O & EndRow).SelectSet R7 = Selection'Now merge it all togetherSet MultiRange = Union(R1, R2, R3, R4, R5, R6, R7)MultiRange.SelectSelection.CopyEnd SubThis 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.  
Select and Paste Rows in a Different Location
vba;excel
Looking at the screenshot you just added was very helpful!For the task I'd suggest code similar to this:Main functions:Option ExplicitPrivate Const DATA_WS As String = BLOCK   'Name of Worksheets containing dataPublic Sub main()    distributeData Sheet1End SubPublic 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 IfEnd SubHelper function: determine last cell of data on the sheetPublic 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 IfEnd FunctionHelper function: removes previous data sheetsPrivate 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 onEnd SubTest file - Main sheet:Result - Separate sheets: