Solved

Need help with Excel Macro and Subtotals

Posted on 2010-11-13
7
420 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
  • 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
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

A theme is a collection of property settings that allow you to define the look of pages and controls, and then apply the look consistently across pages in an application. Themes can be made up of a set of elements: skins, style sheets, images, and o…
Entering time in Microsoft Access can be difficult. An input mask often bothers users more than helping them and won't catch all typing errors. This article shows how to create a textbox for 24-hour time input with full validation politely catching …
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

762 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

Need Help in Real-Time?

Connect with top rated Experts

22 Experts available now in Live!

Get 1:1 Help Now