我正在尝试自动化我们经常在工作中使用的文件。它或多或少是带有编号和任务描述的报价,并分为不同的组。

通常,我们手动输入数据,然后我们必须创建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和下一个,但无法使其正常工作。

这是称为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


还有我创建幻灯片和插入幻灯片等的代码(已编辑,仅保留相关内容,希望我不会破坏/忘记任何事情:))变量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


那么,有人知道我应该如何继续取得预期的结果吗?我不确定是否足够清楚,但我尝试尽可能地透彻。

谢谢。

最佳答案

如果我了解您要完成的工作,那么您需要做的是形成一个定义组数据的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

10-05 17:59