Solved

Need help with Excel Macro and Subtotals

Posted on 2010-11-13
7
428 Views
Last Modified: 2012-05-10
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/2010,R,C,50000,,Alpha - Pledge
11-1111-1111-A00000,5/29/2010,R,C,50000,,Beta - Pledge
22-2222-2222-B00000,4/28/2010,R,D,25000,,Alpha - Pledge
22-2222-2222-B00000,4/28/2010,R,D,25000,,Beta - Pledge
33-3333-3333-C00000,6/14/2010,R,D,1502.5,,Alpha - Pledge
33-3333-3333-C00000,6/14/2010,R,D,1502.5,,Beta - Pledge

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/2010,R,C,10000,Alpha - Pledge
11-1111-1111-A00000,5/29/2010,R,C,10000,Alpha - Pledge
11-1111-1111-A00000,5/29/2010,R,D,10000,Alpha - Pledge
11-1111-1111-A00000,5/29/2010,R,C,10000,Alpha - Pledge
11-1111-1111-A00000,5/29/2010,R,C,10000,Alpha - Pledge original.csv
0
Comment
Question by:BigBadWolf_000
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 3
7 Comments
 
LVL 23

Expert Comment

by:Michael74
ID: 34129203
Here you go. Just place the file book1.xls in the same location as original.csv and run
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:G30")
         .Apply
      End With
   End With
   
   currentRow = 1
   a = csv.ActiveSheet.Range("A1").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) = csv.ActiveSheet.Range("B" & i).Value
            newWB.ActiveSheet.Range("C" & currentRow) = csv.ActiveSheet.Range("C" & i).Value
            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
            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

Open in new window

Book1.xls
0
 
LVL 14

Author Comment

by:BigBadWolf_000
ID: 34129331
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,1502.5,,Beta - Pledge

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
0
 
LVL 23

Expert Comment

by:Michael74
ID: 34129370
BBW

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

Open in new window

0
Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

 
LVL 4

Expert Comment

by:BrainB
ID: 34129384
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.


'================================================================================
'- 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
'---------------------------------------------------------------------------------

Open in new window

0
 
LVL 14

Author Comment

by:BigBadWolf_000
ID: 34129497
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
0
 
LVL 23

Accepted Solution

by:
Michael74 earned 500 total points
ID: 34129684
BBW

Done.

Note - In testing the new code I found a small error which I have resolved as well.

Please let me know if there is any other changes required
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).Value
            b = csv.ActiveSheet.Range("B" & i).Value
            c = csv.ActiveSheet.Range("C" & i).Value
            d = csv.ActiveSheet.Range("D" & i).Value
            count = csv.ActiveSheet.Range("E" & i).Value
            g = csv.ActiveSheet.Range("G" & i).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) & _
          "The error is line the line with the following values" & Chr(10) & _
          "Column A: " & a & Chr(10) & _
          "Column G: " & g & Chr(10) & _
          "Please check original.csv before rerunning", vbCritical, "Error"
   newWB.Close False
   csv.Close False
End Sub

Open in new window

0
 
LVL 14

Author Closing Comment

by:BigBadWolf_000
ID: 34131782
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.
0

Featured Post

Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

733 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question