Solved

How can i parse this data using VBA in excel?

Posted on 2011-03-10
3
278 Views
Last Modified: 2012-05-11
The file shows 3 levels of product information product type, company and product. Also imagine 100's of product types and 100's of months of data. It all follows the same basic layout throughout.

Beside the product's are monthly sales dollars and units sold. I'd like to put together a 2d array (is that possible with vba?) that would contain this information in a usable way.
EExample.xls
0
Comment
Question by:sanjangeorge
[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
  • 2
3 Comments
 
LVL 39

Expert Comment

by:nutsch
ID: 35097953
Two steps
1. Run the below code
Private Sub CleanUpAgain()
Dim lastRow As Long, i As Long 'define variables
application.ScreenUpdating = False 'disable ScreenUpdating to avoid screen flashes

lastRow = Cells(Rows.Count, "C").End(xlUp).Row 'get last row

With range("A6:B" & lastRow)
    .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With

Rows("5:6").Delete

Cells(4, 1) = "TYPE"
Cells(4, 2) = "COMPANY"
Cells(4, 3) = "PRODUCT"

With Cells(4, 1).CurrentRegion
    .AutoFilter Field:=3, Criteria1:="="
    .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .AutoFilter
End With

For i = 4 To Cells(4, Columns.Count).End(xlToLeft).Column
    Cells(3, i) = Left(Cells(4, i), Len(Cells(4, i)) - InStr(StrReverse(Cells(4, i)), " "))
    Cells(4, i) = Trim(Right(Cells(4, i), InStr(StrReverse(Cells(4, i)), " ")))
Next i

application.ScreenUpdating = True 'reenable ScreenUpdating
End Sub

Open in new window


2. select cell D5 (the first cell of your formatted detailed data and run the attached add-in with the default parameters

You're done.

Thomas
Table2DB.xla
0
 
LVL 39

Accepted Solution

by:
nutsch earned 500 total points
ID: 35098652
Removing the add-in, one macro to run with a private sub to help

Thomas
Private Sub CleanUpAgain()
Dim lastRow As Long, i As Long 'define variables
application.ScreenUpdating = False 'disable ScreenUpdating to avoid screen flashes

lastRow = Cells(Rows.Count, "C").End(xlUp).Row 'get last row

With range("A6:B" & lastRow)
    .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With

Rows("5:6").Delete

Cells(4, 1) = "TYPE"
Cells(4, 2) = "COMPANY"
Cells(4, 3) = "PRODUCT"

With Cells(4, 1).CurrentRegion
    .AutoFilter Field:=3, Criteria1:="="
    .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .AutoFilter
End With

For i = 4 To Cells(4, Columns.Count).End(xlToLeft).Column
    Cells(3, i) = Left(Cells(4, i), Len(Cells(4, i)) - InStr(StrReverse(Cells(4, i)), " "))
    Cells(4, i) = Trim(Right(Cells(4, i), InStr(StrReverse(Cells(4, i)), " ")))
Next i

Call TABLE2DB_Convert_withParameters(ActiveSheet.Cells(4, 1).CurrentRegion, ActiveSheet.Cells(5, "D"), "Transformed", "Month", "Amount")

application.ScreenUpdating = True 'reenable ScreenUpdating
End Sub


Private Sub TABLE2DB_Convert_withParameters(rgTable As Range, rgDetail As Range, strShtTo As String, strColName As String, strDataName As String, _
                            Optional blDeleteZeroes As Boolean = False, Optional blDeleteBlanks As Boolean = False)
'new version with copy instead of cell by cell transfer

Dim Row_Header(1 To 5000, 1 To 200) As String, RowNum As Double, ColNum As Double
Dim Col_Header(1 To 200), colCount As Long, LineCount As Long
Dim RowCount As Long, colLoop As Long, _
    arValue(1 To 5000, 1 To 200), intLoop As Double
Dim ShtName As String, intCol As Long, intLine As Long, _
    strDetail As String, strType As String, sht As Worksheet, blSheetExists As Boolean
Dim i As Integer, j As Integer
Dim rngCol As Long, rngRow As Long, rngCols As Long, rngRows As Long, clCol As Long, clRow As Long
Dim rngRowHead As Range
Dim strRange As String, strCell As String
Dim bolNewSht As Boolean
Dim strHead1 As String, strHead2 As String
Dim ctrl As Control
Dim shtFrom As Worksheet, shtTo As Worksheet

application.ScreenUpdating = False
application.Calculation = xlCalculationManual

Set shtFrom = ActiveSheet

blSheetExists = False

For Each sht In ActiveWorkbook.Worksheets
    If sht.Name = strShtTo Then blSheetExists = True
Next

If blSheetExists Then
    Set shtTo = Sheets(strShtTo)
    With shtTo.Cells
        .ClearContents
        .ClearFormats
    End With
Else
    Set shtTo = ActiveWorkbook.Sheets.Add
    
    On Error Resume Next
    shtTo.Name = strShtTo
    If Err <> 0 Then
        Err.Clear
        MsgBox "This sheet name is already in use. Macro is continuing with a different sheet name."
    End If
    
    On Error GoTo 0
End If

With rgTable
    'get data position
    rngRow = .Row
    rngCol = .Column
    rngCols = .Columns.Count
    rngRows = .Rows.Count
End With

With rgDetail
    clCol = .Column
    clRow = .Row
End With

With shtFrom
    Set rngRowHead = .Range(.Cells(clRow, rngCol), .Cells(rngRows + rngRow - 1, clCol - 1))
    'copy column headers
    .Range(.Cells(clRow - 1, rngCol), .Cells(clRow - 1, clCol - 1)).Copy shtTo.Cells(1, 1)
End With

'get column header description
shtTo.Cells(1, clCol - rngCol + 1) = strColName

'get data description
shtTo.Cells(1, clCol - rngCol + 2 + (clRow - rngRow - 1)) = strDataName

'copy row headers
Dim intRow As Long
intRow = 2

For colLoop = clCol To rngCols + rngCol - 1

    rngRowHead.Copy shtTo.Range("A" & intRow)

    shtFrom.Range(shtFrom.Cells(rngRow, colLoop), shtFrom.Cells(clRow - 1, colLoop)).Copy
        
    shtTo.Cells(intRow, rngRowHead.Columns.Count + 1).Resize(rngRows - clRow + rngRow, clRow - rngRow) _
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

    shtFrom.Range(shtFrom.Cells(clRow, colLoop), shtFrom.Cells(rngRows + rngRow - 1, colLoop)).Copy
    
    shtTo.Range(shtTo.Cells(intRow, rngRowHead.Columns.Count + clRow - rngRow + 1), shtTo.Cells(intRow + rngRowHead.Rows.Count - 1, rngRowHead.Columns.Count + clRow - rngRow + 1)).PasteSpecial _
        Paste:=xlPasteValues, Operation:=xlNone

    With shtTo
    
            If blDeleteZeroes Then 'delete zero lines if required
                With .Cells(1, 1).CurrentRegion
                    .AutoFilter Field:=clCol - rngCol + clRow - rngRow + 1, Criteria1:="=0"
                    If WorksheetFunction.Subtotal(3, .Columns(1)) > 1 Then _
                        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                    .AutoFilter
                End With
            End If
        
            If blDeleteBlanks Then 'delete blank lines if required
                With .Cells(1, 1).CurrentRegion
                    .AutoFilter Field:=clCol - rngCol + clRow - rngRow + 1, Criteria1:="="
                    If WorksheetFunction.Subtotal(3, .Columns(1)) > 1 Then _
                        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                    .AutoFilter
                End With
            End If

    End With
    
    intRow = shtTo.Range("A" & Rows.Count).End(xlUp).Row + 1
Next colLoop


ActiveSheet.Cells(1, 1).CurrentRegion.Select
selection.Columns.AutoFit

application.ScreenUpdating = True
application.Calculation = xlCalculationAutomatic

End Sub

Open in new window

0
 

Author Comment

by:sanjangeorge
ID: 35173624
Nutsch,

Is there a way that i could make this script easily adjust to more parameters? for instance if i had more details per product like colour ect? I'm not sure i understand your code well enough to do this myself.

Sanjan
0

Featured Post

Secure Your Active Directory - April 20, 2017

Active Directory plays a critical role in your company’s IT infrastructure and keeping it secure in today’s hacker-infested world is a must.
Microsoft published 300+ pages of guidance, but who has the time, money, and resources to implement? Register now to find an easier way.

Question has a verified solution.

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

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

735 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