代码之家 › 专栏 › 技术社区 › Lack Dranem

VBA查找和读取多个范围

powerpoint excel vba

Lack Dranem · 技术社区 · 7 年前

我正在尝试自动化一个我们在工作中经常使用的文件。它或多或少是一个带有任务编号和描述的引号,组织成不同的组。

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

我有一个问题:我的宏当前检索组名,为每个组创建幻灯片,并将标题放在其中。我想检索每组单元格的值,并将它们粘贴到幻灯片中。但我找不到解决办法。。。看起来并不简单。 Range().Value 无法读取多个单元格。我尝试设置范围变量并检索单元格,但迄今为止没有成功。

很多事情都在发生,但我会尽量弄清楚。我是VBA的初学者,使用我在网上找到的一个函数来搜索我们的组名。我将尽可能地描述代码,并不是所有内容都与问题相关,但我想上下文会有所帮助。

首先,sub查找以关键字“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。例如,“组1”在C6中,“组2”在C13中,等等。我获取值,但我也可以使用 FoundCell.address 。

我试图找回 FoundCell.Address 并将它们放入范围变量中,但它会引发错误,格式必须不正确。我想做的是得到不同的地址,并进行推断。示例:如果我们在C6中有“组1”,在C13中有“组2”,那么我要查找的组1的内容包含在单元格C7到C12中。我试着抵消第一个FoundCell。地址和下一个地址,但我无法让它工作。

以下是调用的函数,顺便说一句:

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

那么,有没有人知道我应该如何取得预期的结果?我不确定这是否足够清楚,但我尽量做到彻底。

谢谢

1 回复 | 直到 7 年前

PeterT 7 年前

如果我了解你想要实现的目标,那么你需要做的就是 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