Solved

How can i parse this data using VBA in excel?

Posted on 2011-03-10
3
272 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
  • 2
3 Comments
 
LVL 39

Expert Comment

by:nutsch
Comment Utility
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
Comment Utility
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
Comment Utility
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

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

Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
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.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

772 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

16 Experts available now in Live!

Get 1:1 Help Now