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