' array list of fields to merge
Dim strMergeFields() As String
' range where merge data comes from
Dim rngSourceRange As Excel.Range
' path to workbook containing template
Dim strTemplatePath As String
' name of merge sheet on template
Dim strSheetName As String
' track user cancellation
Dim cancelled As Boolean
Private Sub initGlobals()
Dim rngTemp As Excel.Range
Dim wkbTemp As Excel.Workbook
Dim iSize As Long
Dim iCount As Long
' get source range
On Error Resume Next
Set rngSourceRange = Application.InputBox( _
Prompt:="Select source data range. Include headers.", _
Title:="Merge: Select Source Data", _
Type:=8)
On Error GoTo 0
If rngSourceRange Is Nothing Then
cancelled = True
Exit Sub
End If
If (rngSourceRange.Rows.Count < 2) Then
cancelled = True
Call MsgBox("You must select a range with at least two rows.", _
vbOKOnly + vbExclamation, "Merge: Error")
Exit Sub
End If
' resize array as needed
iSize = rngSourceRange.Columns.Count
ReDim strMergeFields(1 To iSize)
' get template file name
With Application.FileDialog(Office.MsoFileDialogType.msoFileDialogFilePicker)
.AllowMultiSelect = False
With .Filters
.Clear
.Add "Excel Files", "*.xl*"
End With
If .Show = False Then
cancelled = True
Exit Sub
End If
strTemplatePath = .SelectedItems(1)
End With
Set wkbTemp = Application.Workbooks.Open(strTemplatePath)
wkbTemp.Activate
' get ranges to populate
For iCount = LBound(strMergeFields) To UBound(strMergeFields)
On Error Resume Next
Set rngTemp = Application.InputBox( _
Prompt:="Select range(s) to populate with " & _
rngSourceRange.Rows(1).Cells(iCount) & ". " & vbCrLf & _
"Hold Ctrl to select multiple cells.", _
Title:="Merge: Select Merge Fields", _
Type:=8)
On Error GoTo 0
If rngTemp Is Nothing Then
cancelled = True
Exit Sub
End If
strMergeFields(iCount) = rngTemp.Address
If Len(strSheetName) = 0 Then
strSheetName = Application.ActiveWorkbook.ActiveSheet.Name
Else
If (strSheetName <> Application.ActiveWorkbook.ActiveSheet.Name) Then
cancelled = True
Call MsgBox("Merge fields must be on the same sheet.", _
vbOKOnly + vbCritical, "Merge: Error")
wkbTemp.Close (False)
Exit Sub
End If
End If
Next iCount
wkbTemp.Close (False)
End Sub
Public Sub doMerge()
Dim iSourceRow As Long
Dim iFieldNum As Long
Dim wkbTemp As Excel.Workbook
Dim wshTemp As Excel.Worksheet
Dim strTemp As String
Call initGlobals
If (cancelled) Then Exit Sub
Dim answer As VBA.VbMsgBoxResult
answer = MsgBox("Create separate workbook for each record?", _
vbYesNoCancel, "How you wanna rip it?")
If answer = vbCancel Then Exit Sub
Application.ScreenUpdating = False
If answer = vbNo Then
Set wkbTemp = Application.Workbooks.Add(strTemplatePath)
End If
' go through all row records
For iSourceRow = 2 To rngSourceRange.Rows.Count
' make a new workbook based on template
If answer = vbYes Then
Set wkbTemp = Application.Workbooks.Add(strTemplatePath)
Set wshTemp = wkbTemp.Worksheets(strSheetName)
Else
wkbTemp.Worksheets(strSheetName).Copy _
after:=wkbTemp.Worksheets(wkbTemp.Worksheets.Count)
Set wshTemp = wkbTemp.Worksheets(wkbTemp.Worksheets.Count)
End If
' populate fields
For iFieldNum = LBound(strMergeFields) To UBound(strMergeFields)
wshTemp.Range(strMergeFields(iFieldNum)).Value = _
rngSourceRange.Cells(iSourceRow, iFieldNum).Value
Next iFieldNum
If answer = vbYes Then
' make a name for the new merge
strTemp = ThisWorkbook.Path
If Right$(strTemp, 1) <> "\" Then
strTemp = strTemp & "\"
End If
strTemp = strTemp & Format(Now(), "yyyy-mm-dd_hhmmss_") & "merge_" & iSourceRow - 1
' save the file and close
wkbTemp.SaveAs strTemp, ThisWorkbook.FileFormat
wkbTemp.Close False
End If
Next iSourceRow
If answer = vbNo Then
' make a name for the new merge
strTemp = ThisWorkbook.Path
If Right$(strTemp, 1) <> "\" Then
strTemp = strTemp & "\"
End If
strTemp = strTemp & Format(Now(), "yyyy-mm-dd_hhmmss_") & "merge"
Application.DisplayAlerts = False
wkbTemp.Worksheets(strSheetName).Delete
Application.DisplayAlerts = True
' save the file and close
wkbTemp.SaveAs strTemp, ThisWorkbook.FileFormat
wkbTemp.Close False
End If
Application.ScreenUpdating = False
Call MsgBox("Merge completed!", vbOKOnly + vbInformation, "Merge: Completed")
End Sub
