Excel Macro to group data

[dlanden]

Hello everyone. I am trying to figure out a way to consolidate or group some data that I get on a weekly basis. I would like to create a Macro to make this process even quicker each week. Here is a sample of my data.

Column A Column B Column C Column D Column E Column F Column G Column H
1004 RIV 03 03/01/08 CR-R123 COREMART 111.12 0
1004 RIV 03 03/01/08 CR-R123 CENTRAL 123.56 0
1004 RIV 03 03/01/08 CR-R123 APNE 0 56.23
1004 RIV 03 03/02/08 CR-R222 DILLON 189.56
1004 RIV 03 03/02/08 CR-R222 APNE 87.65
1004 RIV 03 03/02/08 CR-R222 KWIK 653.25

What I need to do is group each row that has the same data in column "E" and get a total for column "G" and Column "H". I also need to keep the date that is assinged to column "D" with these corresponding totals. Here is what my data should look like once it is grouped together:

Column D Column E Column G Column H
03/01/08 CR-R123 234.68 0
03/01/08 CR-R123 0 56.23
03/02/08 CR-R222 842.81 0
03/02/08 CR-R222 0 87.65

Any help would be much appreciated.
Thanks,
Dave

 

[dlanden]

"Right click the date field and Group by day." I tried to right click the date field (after the pivot table was created) but did not see an option to group by day. I am probably doing something incorrectly.

 

[Fazza]

Dave,

The code uses field header in the SQL. I have assumed the headers are EXACTLY: A, B, C, D, E, F, G & H.

This is one approach. There are variations available.

HTH, Fazza

Sub ADO_to_newWbk()

  Dim i As Long
  Dim strConn As String
  Dim strSQL As String
  Dim objRS As Object
  Dim wbkNew As Workbook

  Range("A1").CurrentRegion.Name = "MyData"

  strConn = Join$(Array("Provider=Microsoft.Jet.OLEDB.4.0; Data Source=", _
      ActiveWorkbook.FullName, ";Extended Properties=""Excel 8.0;"""), vbNullString)

  strSQL = Join$(Array( _
      "SELECT D, E, Sum(G) AS [G], H", _
      "FROM MyData", _
      "WHERE H=0", _
      "GROUP BY D, E, H", _
      "UNION", _
      "SELECT D, E, G, Sum(H) AS [H]", _
      "FROM MyData", _
      "WHERE G=0", _
      "GROUP BY D, E, G", _
      "ORDER BY D, E, H"), vbCr)
      
  Set objRS = CreateObject("ADODB.Recordset")
  With objRS
    .Open strSQL, strConn
    Set wbkNew = Workbooks.Add(template:=xlWBATWorksheet)
    wbkNew.Worksheets(1).Cells(2, 1).CopyFromRecordset objRS

    For i = 0 To .fields.Count - 1
      wbkNew.Worksheets(1).Cells(1, i + 1).Value = .fields(i).Name
    Next i

    .Close
  End With

  Set objRS = Nothing
  Set wbkNew = Nothing

End Sub

 

[Fazza]

PS

In case it is better for you, please note that if using a query table, no VBA is required.

regards, F

 

[dlanden]

Fazza,
I copied your code into VB (in excel) and it didn't work. It gave me an error on the line of code for: " .Open strSQL, strConn". I don't believe I am working in SQL?
Dave

 

[Fazza]

Dave,

Maybe you are working in Excel 2007? I'm not familiar with what might need to change to suit Excel 2007.

Otherwise it should be OK. Can you post the headers or, if not, 'double check' them?

regards, Fazza

 

[dlanden]

Fazza,
I am using Excel 2007. I think I have found a solution to this problem outside of excel. I would prefer to use Excel but I am running out of time to work on this. I appreciate all of your help and the others who have helped me you are very nice people.
Thanks,
Dave

 

[Fazza]

OK, Dave. Good work in finding a solution.

From this site http://www.connectionstrings.com/default.aspx
And this page http://www.connectionstrings.com/default.aspx?carrier=excel2007
There is info on Excel 2007 connection strings.
It is the only item that I'd expect needs to be changed for the code to work in Excel 2007.
If it was like I'd expect, below would work in Excel 2007.
Untested.

Regards, Fazza

Sub ADO_to_newWbk()

  Dim i As Long
  Dim strConn As String
  Dim strSQL As String
  Dim objRS As Object
  Dim wbkNew As Workbook

  Range("A1").CurrentRegion.Name = "MyData"

  'connection string to suit whether Excel 2007 (version > 11) or earlier. UNTESTED
  'Connection string information from http://www.connectionstrings.com/default.aspx
  If Application.Version > 11 Then
    strConn = Join$(Array("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=", _
        ActiveWorkbook.FullName, ";Extended Properties=""Excel 12.0 Macro;HDR=YES"";"), vbNullString)
  Else
    strConn = Join$(Array("Provider=Microsoft.Jet.OLEDB.4.0; Data Source=", _
        ActiveWorkbook.FullName, ";Extended Properties=""Excel 8.0;"""), vbNullString)
  End If

  strSQL = Join$(Array( _
      "SELECT D, E, Sum(G) AS [G], H", _
      "FROM MyData", _
      "WHERE H=0", _
      "GROUP BY D, E, H", _
      "UNION", _
      "SELECT D, E, G, Sum(H) AS [H]", _
      "FROM MyData", _
      "WHERE G=0", _
      "GROUP BY D, E, G", _
      "ORDER BY D, E, H"), vbCr)

  Set objRS = CreateObject("ADODB.Recordset")
  With objRS
    .Open strSQL, strConn
    Set wbkNew = Workbooks.Add(template:=xlWBATWorksheet)
    wbkNew.Worksheets(1).Cells(2, 1).CopyFromRecordset objRS

    For i = 0 To .fields.Count - 1
      wbkNew.Worksheets(1).Cells(1, i + 1).Value = .fields(i).Name
    Next i

    .Close
  End With

  Set objRS = Nothing
  Set wbkNew = Nothing

End Sub