VBA Finding and reading multiple ranges - vba

Question

I'm trying to automate a file we use regularly at work. It's more or less a quote with numbers and descriptions of tasks, organized into different groups.
Usually we enter the data manually, then we have to create a Powerpoint presentation and copy-paste a lot of infos. I'm trying to automate the process so we can click on a button -> creates our Powerpoint with all the data in it.
I'm having trouble on one part : My macro currently retrieves the group names and creates slides for each group and puts the title in it. I'd like to retrieve the values of the cells of each group to paste them into the slide also. But I can't find a solution to do it... doesn't seem simple.
Range().Value can't read more than one cell. I tried setting ranges variables and retrieving the cells but no luck so far.
A lot is going on but I'll try to be as clear as possible. I'm a beginner in VBA and used a function I found online to search for our group names. I'll try to describe the code as best as I can, not everything will be relevant to the question but I guess context will help.
First the sub to find the group names that all start with the keyword "Lot" :
Public FoundCells As Range
Public FoundCell As Range
Public NomsLots As String
Sub FindLots()
Dim SearchRange As Range
Dim FindWhat As Variant
NomsLots = ""
Set SearchRange = Range("C1:C500") 'Where to search
FindWhat = "Lot" 'Value to look for
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
MatchCase:=True, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare) 'LookIn indicates whether to look in cell values, cell formulas, or cell comments.
'The default is cell values. LookAt indicates whether to look at the entire cell (a match occurs only if the entire content of the cell matches FindWhat). The default is match entire cell.
'SearchOrder indicates whether the search should proceed row-by-row or column-by-column. The default is row-by-row.
'MatchCase indicates whether the text match is case sensitive (MatchCase = True or case insensitive (MatchCase = False). The default if False.
'BeginsWith is a string that indicates that a cell will match only if it begins with the string specified in BeginsWith.
'EndsWith is a string that indicates that a cell will match only if it ends with the string in EndsWith. The comparisons carried out against BeginsWith and EndsWith are case sensitive if BeginEndCompare is vbBinaryCompare. If BeginEndCompare is vbTextCompare, the comparison is case-insensitive. The default is vbTextCompare. If both BeginsWith and EndsWith are empty string, no tests of the cell content are performed. If either or both BeginsWith or EndsWith are not empty strings, the LookAt parameter is automatically changed to xlPart.
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Found = False
Else
For Each FoundCell In FoundCells
NomsLots = NomsLots & FoundCell.Value & Chr(10)
Debug.Print "Value Found In Cell: " & FoundCell.Value & " in : " & FoundCell.Address
Next FoundCell
End If
NomsLots = Left(NomsLots, Len(NomsLots) - 1)
End Sub
I use it to retrieve the FoundCell.Value to get the group names contained in C1:C500. For example, "Group 1" is in C6, "Group 2" is in C13, etc. I take the values, but I can also retrieve the adresses with FoundCell.address.
I tried to retrieve FoundCell.Address and put them in a range variable but it throws an error, the formatting must be incorrect. What I wanted to do was get the different adresses, and extrapolate.
Exemple : if we have "Group 1" in C6 and "Group 2" in C13, the content of Group 1 I'm looking for is contained in cells C7 through C12. I tried offsetting the first FoundCell.Address and the next, but I couldn't make it work.
Here is the function called, btw :
Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result. If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
XLookAt = xlPart
Else
XLookAt = LookAt
End If
' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
after:=LastCell, _
LookIn:=LookIn, _
LookAt:=XLookAt, _
SearchOrder:=SearchOrder, _
MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
And my code to create the powerpoint and insert slides, etc. (edited to keep the relevant only, hope I didn't break/forget anything :)) The variable Contentofthegroup doesn't exist, it's just a placeholder to understand where I want to put the data (content of the group) in the slide.
Private Sub CommandButton1_Click()
Dim PptApp As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Dim Diapo As PowerPoint.Slide
Dim PPTtable As PowerPoint.Table
Dim Sh As PowerPoint.Shape
Dim Cs1 As ColorScheme
Dim NbShpe As Integer
Set PptApp = CreateObject("Powerpoint.Application")
Set PptDoc = PptApp.Presentations.Open(ThisWorkbook.Path & "\" & "Powerpointpresentation.pptx")
With PptDoc
'Slide 4
'Insert Titles on a summary page
Set Sh = .Slides(4).Shapes("ShapenameTitle")
FindLots
Sh.TextFrame.TextRange.Text = "Quote for the following actions :" & Chr(13) & NomsLots
Sh.TextFrame.TextRange.Paragraphs(2).IndentLevel = 2
'Creation Slides for each group
Dim MyAr
Dim i As Long 'index of groups
Dim j As Long
Dim pptLayout As CustomLayout
j = 7
MyAr = Split(NomsLots, Chr(10))
For i = LBound(MyAr) To UBound(MyAr)
.Slides.Add Index:=j, Layout:=ppLayoutText
Set Sh = .Slides(j).Shapes("ContentShape")
Sh.TextFrame.TextRange.Text = MyAr(i) & vbCrLf & Contentofthegroup
Sh.TextFrame.TextRange.Paragraphs(2).IndentLevel = 2
j = j + 1
Next
End With
MsgBox "Done"
End Sub
So does anybody have an idea how I should proceed to achieve the desired result ? I'm not sure it is clear enough but I tried to be as thorough as possible.
Thanks.

Answer 1

If I understand what you're trying to accomplish, then what you need to do is to form a Range that defines the group data. In order to capture this, you need to compare the first "found" cell to the next "found" cell. The trick comes when you form the last data group.
Building off your code, I came up with this example to illustrate:
Sub FindLots()
Dim SearchRange As Range
Dim FindWhat As Variant
NomsLots = ""
Set SearchRange = Range("C1:C500") 'Where to search
FindWhat = "Lot" 'Value to look for
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
MatchCase:=True, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare)
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
'Found = False
Else
Dim group As Range
For Each FoundCell In FoundCells
NomsLots = NomsLots & FoundCell.Value & Chr(10)
Debug.Print "Value Found In Cell: " & FoundCell.Value & " in : " & FoundCell.Address
If group Is Nothing Then
'--- first time through the loop, so capture the
' start of the group
Set group = FoundCell
Else
'--- all other times through the loop (except the last)
' we find the beginning of the next group and, logically,
' the end of the previous group
Set group = group.Offset(1, 0).Resize(FoundCell.Row - group.Row - 1, 1)
DoSomethingWithThisGroupData group
'--- we're done with the data, so set the start of the next group
Set group = FoundCell
End If
Next FoundCell
'--- now process the last group, so we have to determine where the
' end of the group data is
Dim lastRow As Long
lastRow = Cells(Cells.Rows.Count, "C").End(xlUp).Row
Set group = group.Offset(1, 0).Resize(lastRow - group.Row, 1)
DoSomethingWithThisGroupData group
End If
NomsLots = Left(NomsLots, Len(NomsLots) - 1)
End Sub
Sub DoSomethingWithThisGroupData(ByRef dataGroup As Range)
'--- something cool happens here
Debug.Print "Range of group data = " & dataGroup.Address
End Sub