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.

Instrument output

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:

Test file - Main sheet

Result - Separate sheets:

Result - Separate sheets

• paul bica: I just realized I forgot to include the firs result sheet in the last image, but it was generated as the rest of them ("BLOCK 1")

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.

• Dave: Very detailed answer, thanks so much. I added a screenshot of the data file I am trying to copy the blocks from. I will implement your suggestions and let you know how things go.
• Dave: Can you take a look at the screenshot I added to the question? I took a look at your suggestions and tried applying them to my situation to no avail. Notice that each block I want to grab is in between the "Name" row and "Group Summaries" row - not alternating as you have in the FindNextBlock Function. I understand the logic but am having trouble implementing it. In essence, I am trying to grab the relevant information from the instrument output (highlighted in green) and paste that into a table on a different sheet.