Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

VBA - Help with existing flatten file

Posted on 2013-06-25
8
Medium Priority
?
406 Views
Last Modified: 2013-06-25
I originally post this question and someone provided assistance with an example.  I tried adding another column without much success.

Originally this is my data:
original data
This was my intended output:
final output with current code
The provided code works, but what if I want to add in another column?  I played around without much luck.  Would like some help in re-modifying the existing VBA to also look at Type in Column A.

Original code need help with:
Sub Flatten()

    Dim LastR As Long, LastC As Long
    Dim arr As Variant
    Dim RCounter As Long, CCounter As Long
    Dim DestArr() As Variant
    Dim DestRow As Long
    Dim wb As Workbook
    
    With ThisWorkbook.Worksheets("Sheet4") 'rename as needed
        LastR = .Cells(.Rows.Count, "b").End(xlUp).Row
        LastC = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range(.Cells(1, "b"), .Cells(LastR, LastC)).Value
    End With

    ReDim DestArr(1 To (LastR - 1) * (LastC - 2), 1 To 3) As Variant
    
    For CCounter = 2 To (LastC - 1)
        For RCounter = 2 To LastR
            DestRow = DestRow + 1
            DestArr(DestRow, 1) = arr(RCounter, 1)
            DestArr(DestRow, 2) = arr(1, CCounter)
            DestArr(DestRow, 3) = arr(RCounter, CCounter)
        Next
    Next
    
    Set wb = Workbooks.Add
    
    [a1:c1] = Array("Module", "User", "Permission")
    [a2].Resize(UBound(DestArr, 1), UBound(DestArr, 2)).Value = DestArr
    
    wb.SaveAs "c:\Test\Foo.xls", xlExcel12
    wb.Close
    
End Sub 

Open in new window


would like to modify so it also see column A
0
Comment
Question by:holemania
  • 5
  • 3
8 Comments
 
LVL 31

Expert Comment

by:gowflow
ID: 39274777
you haven't said how you want the data to be laided out ?

MODULE USER PERMISSION ???

OR

TYPE MODULE USER PERMISSION ???
gowflow
0
 
LVL 31

Expert Comment

by:gowflow
ID: 39274842
Is that what you want ??

Sub Flatten4()

    Dim LastR As Long, LastC As Long
    Dim arr As Variant
    Dim RCounter As Long, CCounter As Long
    Dim DestArr() As Variant
    Dim DestRow As Long
    Dim wb As Workbook
    
    With ThisWorkbook.Worksheets("Sheet1") 'rename as needed
        LastR = .Cells(.Rows.Count, "b").End(xlUp).Row
        LastC = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range(.Cells(1, "A"), .Cells(LastR, LastC)).Value
    End With

    ReDim DestArr(1 To (LastR - 1) * (LastC - 2), 1 To 4) As Variant
    
    For CCounter = 2 To (LastC - 1)
        For RCounter = 2 To LastR
            DestRow = DestRow + 1
            DestArr(DestRow, 1) = arr(RCounter, 1)
            DestArr(DestRow, 2) = arr(2, CCounter) '
            DestArr(DestRow, 3) = arr(1, CCounter + 1)
            DestArr(DestRow, 4) = arr(RCounter, CCounter + 1)
        Next
    Next
    
    Set wb = Workbooks.Add
    
    wb.ActiveSheet.Range("a1:d1") = Array("Type", "Module", "User", "Permission")
    wb.ActiveSheet.Range("a2").Resize(UBound(DestArr, 1), UBound(DestArr, 2)).Value = DestArr
    
    wb.SaveAs "c:\Test\Foo.xls", xlExcel12
    wb.Close
    
End Sub

Open in new window



This should give you a display of
Type      Module      User      Permission


Let me know
gowflow
0
 

Author Comment

by:holemania
ID: 39275007
What you provided is working, but not outputting correctly.  For the Module column, it seems to work for the first 3, but then it's putting permission after that.

Output result
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:holemania
ID: 39275986
Okay, after playing with it some more, I think I got it to work now.

    For CCounter = 2 To (LastC - 1)
        For RCounter = 2 To LastR
            DestRow = DestRow + 1
            DestArr(DestRow, 1) = arr(RCounter, 1)
            DestArr(DestRow, 2) = arr(RCounter, 2) 
            DestArr(DestRow, 3) = arr(1, CCounter + 1)
            DestArr(DestRow, 4) = arr(RCounter, CCounter + 1)
        Next
    Next

Open in new window


Going to see how it works and will update later.
0
 
LVL 31

Accepted Solution

by:
gowflow earned 2000 total points
ID: 39275987
Is that what you want ??

Sub Flatten4()

    Dim LastR As Long, LastC As Long
    Dim arr As Variant
    Dim RCounter As Long, CCounter As Long
    Dim DestArr() As Variant
    Dim DestRow As Long
    Dim wb As Workbook
    
    With ThisWorkbook.Worksheets("Sheet1") 'rename as needed
        LastR = .Cells(.Rows.Count, "b").End(xlUp).Row
        LastC = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range(.Cells(1, "A"), .Cells(LastR, LastC)).Value
    End With

    ReDim DestArr(1 To (LastR - 1) * (LastC - 2), 1 To 4) As Variant
    
    For CCounter = 2 To (LastC - 1)
        For RCounter = 2 To LastR
            DestRow = DestRow + 1
            DestArr(DestRow, 1) = arr(RCounter, 1)
            DestArr(DestRow, 2) = arr(RCounter, 2) '
            DestArr(DestRow, 3) = arr(1, CCounter + 1)
            DestArr(DestRow, 4) = arr(RCounter, CCounter + 1)
        Next
    Next
    
    Set wb = Workbooks.Add
    
    wb.ActiveSheet.Range("a1:d1") = Array("Type", "Module", "User", "Permission")
    wb.ActiveSheet.Range("a2").Resize(UBound(DestArr, 1), UBound(DestArr, 2)).Value = DestArr
    
    wb.SaveAs "c:\Test\Foo.xls", xlExcel12
    wb.Close
    
End Sub

Open in new window


gowflow
0
 
LVL 31

Expert Comment

by:gowflow
ID: 39275991
I didn't see that you posted a trial. Yes you got that correct.
gowflow
0
 

Author Closing Comment

by:holemania
ID: 39276218
Thank you goflow.
0
 
LVL 31

Expert Comment

by:gowflow
ID: 39277141
Your welcome glad I could help
gowflow
0

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.
New style of hardware planning for Microsoft Exchange server.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
In this video you will find out how to export Office 365 mailboxes using the built in eDiscovery tool. Bear in mind that although this method might be useful in some cases, using PST files as Office 365 backup is troublesome in a long run (more on t…

926 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