Sum multiple like rows of imported.txt file based on criteria in column 1 using VBA

 Hello. I have a file that imports into Excel using VBA, does some manipulations, and exports the result to a comma delimited file on a daily basis. Below is a small sample of data. 

I must now sum the contents of column D for all rows whose column A are equal.  For instance, in the sample below, I need to add column D of rows 2 and 3 together and put the result in column G of rows 2 and 3.  Then I would need to sum the contents of column D for rows 4,5, and 6 and put the result in column G for rows 4,5, and 6.  In other words, sum the rows in Column D whose column A are equal. The input will consist of hundreds of rows.

I do not know how to go about doing this.  Can anybody help?

Thank you.

Debbi

  A                      B                  C                       D                      E                                              F

1 ID Name Term Balance Descr Acct Type
2 437389 Doe, John 2015 Fall 88.75 Bookstore Charges BKS
3 437389 Doe, John 2015 Fall 444.45 Tuition TUT
4 541231 Doe, Jane  2015 Fall 94.75 Bookstore Charges BKS
5 541231 Doe, Jane  2015 Fall 100.14 Tuition TUT
6 541231 Doe, Jane  2015 Fall 85.16 BookStore Charges BKS

Here is the existing code:


' Create_CHARGES_file Macro
'
Dim sFname As String
Dim sFile As String
Dim i As Integer
Dim strEmplid As String
Dim strFirst As String
Dim strLast As String
Dim strAcct As String
Dim strNewLine As String
Dim strMaxChg
Dim strAcctNbr
Dim strContinue As String
Dim strpath
Dim strQueryFile
Dim strWB
Dim strDate As String
Dim intResult As Integer
Dim intWriteCt As Integer


    strMaxChg = "800.00"   'max bookstore charge amount
    intWriteCt = 0         'number of lines written to output file
    strAcctNbr = " "       'bookstore account number

    strContinue = "N"
    Do Until IsNumeric(strAcctNbr)  'repeat prompt for account # until a number is entered or Cancel is clicked
        strAcctNbr = Application.InputBox(Prompt:="Enter Bookstore Acct#:", Title:="Bookstore Account Number")
        If strAcctNbr <> False Then  'user didn't press Cancel
            If IsNumeric(strAcctNbr) Then
              strContinue = "Y"
            Else
              MsgBox "Account Number must be entered and must be numeric"
            End If
        End If
    Loop
          
    If strContinue = "Y" Then   'if no errors
        strDate = Format(Date, "mmddyy")
        strpath = "T:\bookstore\"
        strWB = strAcctNbr & "FABooklist" & strDate & ".xls"
        strQueryFile = strpath & strWB
        If Dir(strQueryFile) = "" Then 'if input spreadsheet isn't found
            strContinue = "N"
            MsgBox "Spreadsheet " & strQueryFile & " does not exist"
            ThisWorkbook.Close
        End If
    Else
        strContinue = "N"
    End If
   
    If strContinue = "Y" Then  'if no errors
   
        Application.ScreenUpdating = False  'hide screen processing - improves performance
              
        Workbooks.Open Filename:=strQueryFile  'open the input spreadsheet
        Workbooks(strWB).Activate

        ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range("G3:G5000") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range("E3:E5000") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range("B3:B5000") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("sheet1").Sort
            .SetRange Range("A2:N5000")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
      
       If strAcctNbr = "197" Then
           strDate = "0" & strDate
       End If
      
       sFile = strAcctNbr & "Bookcharges" & strDate & ".txt"
       sFname = strpath & sFile
      
       i = FreeFile
       Open sFname For Output As #i
      
       Range("B3").Select
      
       Do While Not IsEmpty(ActiveCell.Offset(0, 0).Value) 'process until a blank cell in column B (ID) is reached
      
            If ActiveCell.Offset(0, 2).Value > 0 And IsNumeric(ActiveCell.Offset(0, 2)) Then
      
                strEmplid = ActiveCell.Offset(0, 0).Value
                strFirst = ActiveCell.Offset(0, 3).Value
                strLast = ActiveCell.Offset(0, 5).Value
               
                strNewLine = ",,,,," & Chr(34) & strEmplid & Chr(34) & "," & _
                             Chr(34) & strFirst & Chr(34) & ",," & _
                             Chr(34) & strLast & Chr(34) & _
                             ",,,,,,," & Chr(34) & _
                             Chr(34) & "," & Chr(34) & strEmplid & Chr(34) & _
                             ",,,,,,,,,,," & _
                             Chr(34) & strMaxChg & Chr(34) & ",,," & _
                             Chr(34) & strAcctNbr & Chr(34) & _
                             ",,,,,,,"
               
                Print #i, strNewLine
               
                intWriteCt = intWriteCt + 1
           
            End If
           
            ActiveCell.Offset(1, 0).Select  'advance to the next row
      
       Loop
       
       Close #i
      
       ActiveWorkbook.Close SaveChanges:=False
       Application.ScreenUpdating = True
      
       MsgBox "File  " & sFile & "  was successfully created." & Chr(10) & Chr(10) & _
              "Lines written:  " & intWriteCt  'display the # of lines written for comparison to the spreadsheet row count
      
       intResult = Shell("Notepad.exe " & sFname, vbMaximizedFocus) 'open the file in Notepad
       
    End If
   
    ThisWorkbook.Close
   
End Sub









  • Edited by DBeVille 16 hours 44 minutes ago
September 14th, 2015 10:33am

Below the line that opens the file, insert

        Dim n As Long
        n = Range("B" & Rows.Count).End(xlUp).Row
        Range("G2:G" & n).Formula = "=SUMIF($B$2:$B$" & n & ",$B2,$D$2:$D$" & n & ")"

Free Windows Admin Tool Kit Click here and download it now
September 14th, 2015 11:43am