VBA 查找和读取多个范围

Question

我正在尝试自动化我们在工作中经常使用的文件。它或多或少是一个引用，其中包含任务的数字和描述，并组织成不同的组。

通常我们手动输入数据，然后我们必须创建一个 Powerpoint 演示文稿并复制粘贴大量信息。我正在尝试使该过程自动化，以便我们可以单击一个按钮 -> 创建包含其中所有数据的 Powerpoint。

我在一个方面遇到了麻烦:我的宏当前检索组名称并为每个组创建幻灯片并将标题放入其中。我想检索每组单元格的值，并将它们粘贴到幻灯片中。但我找不到解决方案......似乎并不简单。Range().Value 无法读取多个单元格。我尝试设置范围变量并检索单元格，但到目前为止没有运气。

发生了很多事情，但我会尽量说得清楚。我是 VBA 的初学者，使用我在网上找到的函数来搜索我们的组名称。我会尽力描述代码，并非所有内容都与问题相关，但我想上下文会有所帮助。

首先，子程序查找所有以关键字“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

我使用它来检索 FoundCell.Value 以获取 C1:C500 中包含的组名称。例如，“Group 1”在 C6 中，“Group 2”在 C13 中，等等。我获取这些值，但我也可以使用 FoundCell.address 检索地址。

我尝试检索 FoundCell.Address 并将它们放入范围变量中，但它抛出错误，格式一定不正确。我想做的是获取不同的地址并进行推断。示例:如果 C6 中有“组 1”，C13 中有“组 2”，则我要查找的组 1 的内容包含在单元格 C7 到 C12 中。我尝试抵消第一个 FoundCell.Address 和下一个，但无法使其工作。

这里是调用的函数，顺便说一句:

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

我的代码用于创建powerpoint和插入幻灯片等(编辑以仅保留相关内容，希望我没有破坏/忘记任何东西:))变量Contentofthegroup不存在，它只是一个占位符，用于了解我要将数据(组的内容)放在幻灯片中的位置。

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

那么有人知道我应该如何继续实现预期的结果吗？我不确定它是否足够清楚，但我试图尽可能彻底。

谢谢。

Answer 1

如果我理解您想要完成的任务，那么您需要做的就是形成一个定义组数据的Range。为了捕获这一点，您需要将第一个“找到的”单元格与下一个“找到的”单元格进行比较。当您形成最后一个数据组时，技巧就出现了。

根据您的代码，我想出了这个示例来说明:

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