VBA 查找和读取多个范围
VBA Finding and reading multiple ranges
我正在尝试自动化我们在工作中经常使用的文件。它或多或少是包含任务编号和描述的引述，分为不同的组。
通常我们手动输入数据，然后我们必须创建一个 Powerpoint 演示文稿和 copy-paste 很多信息。我正在尝试使该过程自动化，以便我们可以单击一个按钮 -> 创建包含所有数据的 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 中包含的组名。例如，"Group 1" 在 C6 中，"Group 2" 在 C13 中，等等。我取值，但我也可以用 FoundCell.address.
检索地址
我试图检索 FoundCell.Address 并将它们放入一个范围变量中，但它抛出了一个错误，格式一定是不正确的。我想做的是获取不同的地址，然后进行推断。
示例：如果我们在 C6 中有 "Group 1" 并且在 C13 中有 "Group 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 和插入幻灯片等的代码（经过编辑只保留相关内容，希望我没有 break/forget 任何东西:)）变量 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 来定义组数据。为了捕获这一点，您需要将第一个 "found" 单元格与下一个 "found" 单元格进行比较。当您形成最后一个数据组时，技巧就来了。
根据你的代码，我想出了这个例子来说明：
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
我正在尝试自动化我们在工作中经常使用的文件。它或多或少是包含任务编号和描述的引述，分为不同的组。
通常我们手动输入数据，然后我们必须创建一个 Powerpoint 演示文稿和 copy-paste 很多信息。我正在尝试使该过程自动化，以便我们可以单击一个按钮 -> 创建包含所有数据的 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 中包含的组名。例如，"Group 1" 在 C6 中，"Group 2" 在 C13 中，等等。我取值，但我也可以用 FoundCell.address.
我试图检索 FoundCell.Address 并将它们放入一个范围变量中，但它抛出了一个错误，格式一定是不正确的。我想做的是获取不同的地址，然后进行推断。
示例：如果我们在 C6 中有 "Group 1" 并且在 C13 中有 "Group 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 和插入幻灯片等的代码（经过编辑只保留相关内容，希望我没有 break/forget 任何东西:)）变量 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 来定义组数据。为了捕获这一点，您需要将第一个 "found" 单元格与下一个 "found" 单元格进行比较。当您形成最后一个数据组时，技巧就来了。
根据你的代码，我想出了这个例子来说明：
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