Need help with Excel Macro and Subtotals
Excel 2007/2010
Need a macro that opens the (attached) "original.csv" file.
Calculates subtotals sorted by the column 'G'; At each change in column 'A'
The macro can add headers if required
However the end result should be...saves a csv file called "result.csv"
Result file data should be as follows (no headers).....
11-1111-1111-A00000,5/29/2
11-1111-1111-A00000,5/29/2
22-2222-2222-B00000,4/28/2
22-2222-2222-B00000,4/28/2
33-3333-3333-C00000,6/14/2
33-3333-3333-C00000,6/14/2
Other info:
The dates for similar numbers in column 'A' will be the same
Macro should display error and abort process, if for similar numbers in column 'A'....column 'D' has both a C and a D value (correct value for all records with the similar numbers in column 'A' is either a C or a D)
Example of error:
11-1111-1111-A00000,5/29/2
11-1111-1111-A00000,5/29/2
11-1111-1111-A00000,5/29/2
11-1111-1111-A00000,5/29/2
11-1111-1111-A00000,5/29/2
Need a macro that opens the (attached) "original.csv" file.
Calculates subtotals sorted by the column 'G'; At each change in column 'A'
The macro can add headers if required
However the end result should be...saves a csv file called "result.csv"
Result file data should be as follows (no headers).....
11-1111-1111-A00000,5/29/2
11-1111-1111-A00000,5/29/2
22-2222-2222-B00000,4/28/2
22-2222-2222-B00000,4/28/2
33-3333-3333-C00000,6/14/2
33-3333-3333-C00000,6/14/2
Other info:
The dates for similar numbers in column 'A' will be the same
Macro should display error and abort process, if for similar numbers in column 'A'....column 'D' has both a C and a D value (correct value for all records with the similar numbers in column 'A' is either a C or a D)
Example of error:
11-1111-1111-A00000,5/29/2
11-1111-1111-A00000,5/29/2
11-1111-1111-A00000,5/29/2
11-1111-1111-A00000,5/29/2
11-1111-1111-A00000,5/29/2
ASKER
Michael74: Thank you for the quick response and script.
Got the following issue on running the script....
In the last line of the 'result.csv' file the values for column 'B' and column 'C' are missing
i.e. 33-3333-3333-C00000,,,D,15
Also there may be any amount of records in the original.csv file...does the script accomidate for that...only ask cause I noticed...
.SetRange Range("A1:G30")
Regards BBW
Got the following issue on running the script....
In the last line of the 'result.csv' file the values for column 'B' and column 'C' are missing
i.e. 33-3333-3333-C00000,,,D,15
Also there may be any amount of records in the original.csv file...does the script accomidate for that...only ask cause I noticed...
.SetRange Range("A1:G30")
Regards BBW
BBW
Sorry about that. I missed both of thse. Try this amended code. It will work with any number of values
Michael
Sorry about that. I missed both of thse. Try this amended code. It will work with any number of values
Michael
Sub process()
Dim csv As Workbook, newWB As Workbook
Dim lastrow As Long, i As Long, currentRow As Long
Dim a As String, b As String, c As String, d As String, g As String
Dim count As Double
Set csv = Workbooks.Open(ThisWorkbook.Path & "\original.csv")
Set newWB = Workbooks.Add
With csv.ActiveSheet
lastrow = .Cells(Rows.count, "A").End(xlUp).Row
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1:A" & lastrow)
.SortFields.Add Key:=Range("G1:G" & lastrow)
.SetRange Range("A1:G" & lastrow)
.Apply
End With
End With
currentRow = 1
a = csv.ActiveSheet.Range("A1").Value
b = csv.ActiveSheet.Range("B1").Value
c = csv.ActiveSheet.Range("C1").Value
d = csv.ActiveSheet.Range("D1").Value
count = csv.ActiveSheet.Range("E1").Value
g = csv.ActiveSheet.Range("G1").Value
For i = 2 To lastrow + 1
If a = csv.ActiveSheet.Range("A" & i).Value And _
g = csv.ActiveSheet.Range("G" & i).Value And _
d <> csv.ActiveSheet.Range("D" & i).Value Then
GoTo ErrorHandler
ElseIf a = csv.ActiveSheet.Range("A" & i).Value And _
g = csv.ActiveSheet.Range("G" & i).Value Then
count = count + csv.ActiveSheet.Range("E" & i).Value
Else
newWB.ActiveSheet.Range("A" & currentRow) = a
newWB.ActiveSheet.Range("B" & currentRow) = b
newWB.ActiveSheet.Range("C" & currentRow) = c
newWB.ActiveSheet.Range("D" & currentRow) = d
newWB.ActiveSheet.Range("E" & currentRow) = count
newWB.ActiveSheet.Range("F" & currentRow) = ""
newWB.ActiveSheet.Range("G" & currentRow) = g
a = csv.ActiveSheet.Range("A" & i + 1).Value
b = csv.ActiveSheet.Range("B" & i + 1).Value
c = csv.ActiveSheet.Range("C" & i + 1).Value
d = csv.ActiveSheet.Range("D" & i + 1).Value
count = csv.ActiveSheet.Range("E" & i + 1).Value
g = csv.ActiveSheet.Range("G" & i + 1).Value
currentRow = currentRow + 1
End If
Next
newWB.SaveAs csv.Path & "\result.csv"
newWB.Close False
csv.Close False
MsgBox "Processing completed successfully"
Exit Sub
ErrorHandler:
MsgBox "There is an error in the data" & Chr(10) & "Please check original.csv before rerunning", vbCritical, "Error"
newWB.Close False
csv.Close False
End Sub
My code is below and seems to work Ok. It is laid out so you can see what it does, and make changes later on if you need. I have tried a few error checks. Please let me know if there are any problems or you need any tweaks.
It does the C & D check. I have set this to go to the appropriate "problem" row in the csv and stop the macro. If you need it to just finish with a message I can change that - or you can just change the 'Private Sub ERROR_MESSAGE' to do something else.
I was not sure that you needed this error check to include or ignore the Pledge, so it does both. I have disabled the "without Pledge\sorted column A only routine". You just need to uncomment the line of code to run the subroutine if you need it. If you do that, the second check still runs, but there will be no error to find. The error code goes to the appropriate row in the csv data and stops the macro.
My Excel changes the date format of the .csv file, so I make sure it is converted to "m/d/yyyy".
The results file is opened in Notepad at the end for checking.
It does the C & D check. I have set this to go to the appropriate "problem" row in the csv and stop the macro. If you need it to just finish with a message I can change that - or you can just change the 'Private Sub ERROR_MESSAGE' to do something else.
I was not sure that you needed this error check to include or ignore the Pledge, so it does both. I have disabled the "without Pledge\sorted column A only routine". You just need to uncomment the line of code to run the subroutine if you need it. If you do that, the second check still runs, but there will be no error to find. The error code goes to the appropriate row in the csv data and stops the macro.
My Excel changes the date format of the .csv file, so I make sure it is converted to "m/d/yyyy".
The results file is opened in Notepad at the end for checking.
'================================================================================
'- OPEN A TEXT FILE & PROCESS. EXPORT RESULTS TO .CSV
'- Checks for C & D errors
'- Excel converts column B to a date. Need to check final date format
'- The new text file is opened in Notepad at the end
'- A check for Column A error ignoring Pledge is available. Currently disabled below.
'- Brian Baulsom November 2010
'================================================================================
Dim MyFolder As String
Dim MyFile As String
Dim FromSheet As Worksheet
Dim MyRow As Long
Dim LastRow
Dim MyValue As String
Dim MyValue2 As String
'--------------------------
Dim Results As Worksheet
Dim TotalC As Double
Dim TotalD As Double
Dim CD As String
Dim ToSheet As Worksheet
Dim ToRow As Long
'================================================================================
'- MAIN ROUTINE
'================================================================================
Sub COUNT_LINES()
'----------------------------------------------------------------------------
MyFolder = "F:\My Downloads\"
MyFile = "original.csv"
'----------------------------------------------------------------------------
'- ORIGINAL SHEET
Workbooks.Open Filename:=MyFolder & MyFile
Set FromSheet = ActiveSheet
LastRow = FromSheet.Range("A65536").End(xlUp).Row
Application.Calculation = xlCalculationManual
'============================================================================
'- CHECK COLUMN A FOR ERROR C + D COLUMN D *******************
'CHECK_FOR_ERROR
'============================================================================
With FromSheet
'- COLUMN G SUMMARY VALUES
.Range("A1:G" & LastRow).Sort Key1:=Range("G1"), Order1:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'-----------------------------------------------------------------------------
'- TEMPORARY SHEET
Worksheets.Add
Set Results = ActiveSheet
ActiveSheet.Name = "Results"
ToRow = 1
'-----------------------------------------------------------------------------
'- DATA LOOP : CHECK COLUMN G
MyRow = 1
While MyRow <= LastRow
MyValue = .Cells(MyRow, "G").Value
MyValue2 = .Cells(MyRow, "A").Value
TotalC = 0
TotalD = 0
'------------------------------------------------------------------------
'- PLEDGE
While .Cells(MyRow, "G").Value = MyValue _
And .Cells(MyRow, "A").Value = MyValue2 And MyRow <= LastRow
'-
CD = UCase(.Cells(MyRow, "D").Value)
'--------------------------------------------------------------------
If CD = "C" Then
TotalC = TotalC + CDbl(.Cells(MyRow, "E").Value)
If TotalD > 0 Then ERROR_MESSAGE
ElseIf CD = "D" Then
TotalD = TotalD + CDbl(.Cells(MyRow, "E").Value)
If TotalC > 0 Then ERROR_MESSAGE
Else
MsgBox ("There is an error in Column D row " & MyRow & vbCr _
& "Value = " & CD & vbCr & "Not a C or D")
End
End If
MyRow = MyRow + 1
Wend
'------------------------------------------------------------------------
'- TRANSFER TOTALS
Results.Cells(ToRow, "A").Value = FromSheet.Cells(MyRow - 1, "A").Value
Results.Cells(ToRow, "B").Value = Format(FromSheet.Cells(MyRow - 1, "B").Value, "m/d/yyyy")
Results.Cells(ToRow, "C").Value = FromSheet.Cells(MyRow - 1, "C").Value
Results.Cells(ToRow, "D").Value = FromSheet.Cells(MyRow - 1, "D").Value
Results.Cells(ToRow, "E").Value = IIf(TotalC > 0, TotalC, TotalD)
Results.Cells(ToRow, "G").Value = FromSheet.Cells(MyRow - 1, "G").Value
ToRow = ToRow + 1
Wend
'----------------------------------------------------------------------------
End With
'===============================================================================
'- RESULTS : FINISH
With Results.Range("A1:G" & LastRow)
.Sort Key1:=Range("A1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'----------------------------------------------------------------------------
.Columns.AutoFit
End With
'----------------------------------------------------------------------------------
Application.DisplayAlerts = False
Sheets("Original").Delete
With ActiveWorkbook
.SaveAs Filename:=MyFolder & "Results.csv", FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
Application.DisplayAlerts = True
'----------------------------------------------------------------------------
MsgBox ("Complete OK")
rsp = Shell("C:\Windows\Notepad.exe " & MyFolder & "Results.csv")
End Sub
'--------------------------------------------------------------------------------
'================================================================================
'- ERROR MESSAGE C - D : GO TO ROW
'================================================================================
Private Sub ERROR_MESSAGE()
MsgBox ("Error with " & FromSheet.Cells(MyRow, "A").Value & " " _
& FromSheet.Cells(MyRow, "G").Value & vbCr & "Row " & MyRow - 1)
Application.Goto FromSheet.Range("A" & MyRow), False
End
End Sub
'-------------------------------------------------------------------------------
'================================================================================
'- CHECK COLUMN A FOR ERROR :
'- VALUE COLUMN A HAS C & D IN COLUMN D (IGNORING Pledge value)
'================================================================================
Private Sub CHECK_FOR_ERROR()
With FromSheet
.Range("A1:G" & LastRow).Sort Key1:=Range("A1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
LastRow = FromSheet.Range("A65536").End(xlUp).Row
'----------------------------------------------------------------------------
'- DATA LOOP : CHECK COLUMN A
MyRow = 1
While MyRow <= LastRow
MyValue = .Cells(MyRow, "A").Value
TotalC = 0
TotalD = 0
'------------------------------------------------------------------------
While .Cells(MyRow, 1).Value = MyValue And MyRow <= LastRow
If UCase(.Cells(MyRow, "D").Value) = "C" Then
TotalC = TotalC + 1
If TotalD > 0 Then ERROR_MESSAGE
ElseIf UCase(.Cells(MyRow, "D").Value) = "D" Then
TotalD = TotalD + 1
If TotalC > 0 Then ERROR_MESSAGE
End If
MyRow = MyRow + 1
Wend
'------------------------------------------------------------------------
Wend
'----------------------------------------------------------------------------
End With
End Sub
'---------------------------------------------------------------------------------
ASKER
Michael74: Thanks...works great
Would it be possible to include in the error msg ....
the columnA value and columnG value of said columnA number causing error
Would it be possible to include in the error msg ....
the columnA value and columnG value of said columnA number causing error
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Michael74:: Thank you! works great. Very nice codeing.
BrainB: Thank you for your input. However, I went with "Michael74" code, liked that I did not have to specify C & D values.
BrainB: Thank you for your input. However, I went with "Michael74" code, liked that I did not have to specify C & D values.
Open in new window
Book1.xls