Results 1 to 1 of 1

Expand Code to include more data

Threaded View

  1. #1
    Registered User
    Join Date
    11-23-2013
    Location
    United States of America
    MS-Off Ver
    Excel 2010
    Posts
    2

    Expand Code to include more data

    Hi All,

    Just wanted to ask a question to see if someone might help me. I'm an intermediate excel user and a beginner VBA user. What I need to do is run a mail merge from a database of names and put it into a statement template I made in Excel. I have the merge VBA code completed I just need to enter in the following and they will be separate column in the statement category. The problem I'm running in to is when I merge the database of names and payments to the template is that it is only listing the first check I need to add ina formula to enter in more than one check payment.

    Check #252 $15.00
    Check #353 $25.00
    ETC.

    The Oracle database order is listed below:

    ORDER BY FP_INCOME.DATE_OF_CHECK, FP_INCOME.DATE_ENTERED, FP_INCOME.DATE_RECD, FP_INCOME.CHECK_OR_CASH DESC


    Ther merge formula that is working is listed below just need to know where to fit the above code in:


    ' 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
    Last edited by JBeaucaire; 04-22-2014 at 02:27 AM. Reason: Added missing CODE tags. Please read and follow the Forum Rules, link above in the menu bar. Thanks.

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. [SOLVED] Expand on Parse Function/ Column to Column - Contiguous Data to include quantities
    By arcamp in forum Excel Programming / VBA / Macros
    Replies: 5
    Last Post: 02-21-2013, 05:18 PM
  2. [SOLVED] Code to Include File name in the macro for merging data from workbooks to Worksheet
    By flakedew in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 07-21-2012, 09:37 AM
  3. expand alphabetical sort to include 25 columns
    By simpson in forum Excel General
    Replies: 2
    Last Post: 03-04-2011, 01:56 PM
  4. Updating a code to include the data above rows inserted
    By GAccounting in forum Excel Programming / VBA / Macros
    Replies: 26
    Last Post: 09-10-2010, 06:20 PM
  5. Expand and Collapse Grouping Code
    By Dulanic in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 04-15-2010, 01:03 PM

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1