我正在尝试自动化我们经常在工作中使用的文件。它或多或少是带有编号和任务描述的报价，并分为不同的组。
通常，我们手动输入数据，然后我们必须创建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