в соответствии с выводом @macropod, я решил объединить информацию об элементе объединенных строк, а затем удалить дополнительные строки.
Поскольку сторонний дамп Excel содержал пробелы для объединенных ячеек, в которых не было элемента, я просто удалил любую строку, в которой первая ячейка была пустой.
Затем я немного поборолся с частью задачи по слиянию почты. Оказывается, есть разница между запуском слияния VBA из Excel и запуском его из Word. Я не смог найти прямых примеров использования Word в VBA для извлечения источника данных Excel. Документация для VBA MailMerge немного слабовата в объяснениях, и большинство примеров, кажется, предполагают, что я уже знал, что я делал, но я понял это.
Мой конечный продукт - это документ Word, содержащий заполнители почтовых слияний, куда я хочу передать данные (вы можете сделать это в Word на вкладке «Почтовые рассылки», используя копию данных Excel), с модулем кода VBA, установленным для запуска на Document_Open. О, я выделил функцию randomString для использования в качестве временного имени файла; если вы пытаетесь дублировать мои усилия, вам нужно будет найти или написать один, или просто удалить временный файл после каждого запуска.
Option Explicit
'@Author JPGoetz 20190630
Private Sub Document_Open()
'First, get the user to select the file containing the Item data
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogOpen)
fDialog.Filters.Add "Excel Workbooks", "*.xlsx, *.xls, *.xlxm", 1
Dim blnFileFound As Boolean
Dim strExtension As String
Dim blnTest1 As Boolean
Dim blnTest2 As Boolean
Dim blnTest3 As Boolean
Dim FName As String
Do
fDialog.Show
FName = fDialog.SelectedItems(1)
strExtension = Right(FName, Len(FName) - InStrRev(FName, "."))
blnTest1 = StrComp(strExtension, "xlsx", vbTextCompare)
blnTest2 = StrComp(strExtension, "xlsm", vbTextCompare)
blnTest3 = StrComp(strExtension, "xls", vbTextCompare)
If blnTest1 = 0 Or blnTest2 = 0 Or blnTest3 = 0 Then
blnFileFound = True
Else
MsgBox "Please locate the Item Excel spreadsheet (.xlsx, .xlsm, or .xls)", vbCritical, "Incorrect file format"
End If
DoEvents
Loop While Not blnFileFound
'Now open the Excel spreadsheet chosen in the previous section
Dim objExcel As Excel.Application
Dim objWorkbook As Excel.Workbook
Set objExcel = New Excel.Application
Set objWorkbook = objExcel.Workbooks.Open(FName)
objWorkbook.Worksheets(1).Activate
'If a client has requested multiple Items, the third party's Excel dump will merge the client's info
' across multiple rows (one for each Item)
'What we're going to do is find the merged cells and un-merge them, then concatenate the requests
'Next, find the column containing the Item requested, usually around column 26
Dim sh As Excel.Worksheet
Dim rngItem As Excel.Range 'there's a significant difference between Word.Range and Excel.Range!!
Dim rngHeader As Excel.Range
Dim intItemCol As Integer
Dim strSearch As String
Dim strTemp As String
Set sh = objWorkbook.ActiveSheet
strSearch = "Service / Subsidy"
'find the Item column
Set rngHeader = sh.Cells(1, 1).CurrentRegion.Rows
Set rngItem = rngHeader.Find(What:=strSearch, LookIn:=xlValues, _
Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rngItem Is Nothing Then
rngItem.Cells(1).Select
intItemCol = rngItem.Column
Else
MsgBox "Can't find the Item column, please ensure you selected the correct spreadsheet!", vbCritical
Exit Sub
End If
'Next, run through the rows, and if a client has multiple Items, concatenate them
' Also, add up the costs (the next column from the Items)
' and delete anything to the right of the costs
Dim intCurrentRow As Integer
Dim intRowsInMerge As Integer
Dim strItems As String
Dim intIndex As Integer
Dim intCost As Integer
intCurrentRow = 2
'find merged rows, concatenate services, add up costs, then delete the now-duplicate items (and other cells to the right) from the row
'if the current row is merged, concatenate the merged rows' Item choices and costs
While Not IsEmpty(sh.Cells(intCurrentRow, 1))
If sh.Cells(intCurrentRow, 1).MergeCells Then
'we've hit the first row of a multi-row entry
strItems = ""
intCost = 0
intRowsInMerge = sh.Cells(intCurrentRow, 1).MergeArea.Rows.Count 'how many rows in this merge area?
'for each row in the merged area, extract the Item and concatenate with the ones that have gone before
For intIndex = intCurrentRow To intCurrentRow + intRowsInMerge - 1
strTemp = sh.Cells(intIndex, intItemCol).Value
intCost = intCost + CInt(sh.Cells(intIndex, intItemCol + 1).Value)
'remove the trailing slash, artifact from the spreadsheet creation
strTemp = Left(strTemp, InStrRev(strTemp, "/") - 1)
If strItems = "" Then
strItems = strTemp
Else
strItems = strItems & vbCrLf & strTemp
End If
' remove the item from any line that isn't the first in the merged area
' this isn't the cleanest way, but it was expedient
If intIndex > intCurrentRow Then
sh.Cells(intIndex, intItemCol).Value = ""
sh.Cells(intIndex, intItemCol + 1).Value = ""
sh.Cells(intIndex, intItemCol + 2).Value = ""
sh.Cells(intIndex, intItemCol + 3).Value = ""
sh.Cells(intIndex, intItemCol + 4).Value = ""
End If
Next intIndex
sh.Cells(intCurrentRow, intItemCol).Value = strItems
intCurrentRow = intCurrentRow + intRowsInMerge
Else 'not a merged row, just a single item for this client; just remove the trailing /
strItems = sh.Cells(intCurrentRow, intItemCol).Value
strItems = Left(strItems, InStrRev(strItems, "/") - 1)
sh.Cells(intCurrentRow, intItemCol).Value = strItems
intCurrentRow = intCurrentRow + 1
End If
DoEvents
Wend 'end searching for merged cells
'now un-merge all rows (but don't "copy-down"... we want them to be blank)
Dim Cell As Excel.Range
For Each Cell In sh.UsedRange
If Cell.MergeCells Then
Cell.MergeCells = False
End If
Next
'now remove any blank rows -- starting at the bottom!
Dim rngUsed As Excel.Range
Dim intLastRowIndex As Integer
Dim intRowIndex As Integer
' find the last (effective) row
If objExcel.WorksheetFunction.CountA(sh.Cells) <> 0 Then
intLastRowIndex = _
sh.Cells.Find( _
What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
intLastRowIndex = 1
End If
'now delete any rows where the first cell is empty
For intRowIndex = intLastRowIndex To 1 Step -1
If sh.Cells(intRowIndex, 1) = "" Then
sh.Rows(intRowIndex).Delete
End If
Next intRowIndex
'save the new workbook with temporary name
Dim strTempWorkbookName As String
strTempWorkbookName = objWorkbook.Path & "\tempOutput_" & RandomString(10) & ".xlsx"
objWorkbook.SaveAs strTempWorkbookName
objWorkbook.Close
'now mail merge the forms
Dim wdocSource As Word.Document
Dim wdocDest As Word.Document
Dim myMerge As Word.MailMerge
Set wdocSource = Application.ActiveDocument
'Set wdocDest = Application.Documents.Add
Set myMerge = wdocSource.MailMerge
myMerge.MainDocumentType = wdFormLetters
myMerge.OpenDataSource _
Name:=strTempWorkbookName, _
Connection:="Data Source=" & strTempWorkbookName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `CustomReport$`"
With myMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = intLastRowIndex
End With
.Execute Pause:=False
End With
'release and close object and file handles
Set objExcel = Nothing
Set objWorkbook = Nothing
Set sh = Nothing
Set wdocSource = Nothing
Set wdocDest = Nothing
End Sub ' end Document_open()
Function RandomString(Length As Integer)
dim str as String
str = "randomString" 'develop a random string function here
RandomString = str
End Function