Я пытаюсь автоматизировать файл, который мы регулярно используем на работе. Это более или менее цитата с номерами и описаниями задач, организованная в разные группы.
Обычно мы вводим данные вручную, затем нам нужно создать презентацию 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. Например, «Группа 1» находится в C6, «Группа 2» находится в C13 и т. Д. Я беру значения, но я также могу получить адреса с помощью FoundCell.address.
Я пытался извлечь FoundCell.Address и поместить их в переменную диапазона, но выдает ошибку, форматирование должно быть неправильным. То, что я хотел сделать, это получить разные адреса и экстраполировать.
Пример: если у нас есть «Группа 1» в C6 и «Группа 2» в C13, то содержимое группы 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
Так у кого-нибудь есть идея, как мне поступить, чтобы достичь желаемого результата? Я не уверен, что это достаточно ясно, но я старался быть как можно более тщательным.
Спасибо.