Solved

Need help with Excel Macro and Subtotals

Posted on 2010-11-13
7
422 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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Drop Down List with Unique/Distinct Values (Part II - ComboBox or ListBox and Data Validation List Bonus!) David Miller (dlmille) Intro This article focuses on delivering unique, sorted lists to list objects (e.g., ComboBox, ListBox) and Dat…
Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
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…

867 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

18 Experts available now in Live!

Get 1:1 Help Now