Cfrgtkky

Question

Is there any way to import a range that looks like this:

I'm trying to import a range with an undetermined number of rows and columns. As the 5th row indicates, the range that I wish to import has in the first column business names and in their subsequent columns, different iterations of the same business.

I've been thinking of using arrays but I can't see it being possible as I would have varying dimensions per element (eg. 3 dimensions for canadian tire and 2 dimensions for mercedes).

I've also thought of using collections/dictionaries but I stumble at using and understanding them.

Ultimately, my intentions are to loop the iterations from this range in a column and, if any of these iterations match a cell in my column, to write in an offset cell the first iteration (business name in bold).

Now, I know, I could do a two dimensional array from a range like this, with repeated first iterations (business name):

hello

However, it's quite cumbersome to rewrite business names.
My code below for what I was using for the two dimensional array:

Option Explicit

Sub VendorFinder()



'variable declaration

Dim msg As String

Dim ans As Integer

Dim rng As Range

Dim DescRng As Range

Dim DescCol As Range

Dim VendorCol As Range

Dim j As Long

Dim Vendor As Variant

Dim wb As Workbook

Dim sFile As String

Dim myVendor As Variant

Dim FirstRow As Range

Dim VendorRng As Range



'import vendors

sFile = "Z:Vendor List.xlsx"

Application.ScreenUpdating = False

Set wb = Application.Workbooks.Open(sFile)

Vendor = wb.Sheets(1).Range(Cells(1, 1), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)).Value2

wb.Close False

Application.ScreenUpdating = True



On Error GoTo BadEntry



TryAgain:



'set columns

Set DescCol = Application.InputBox("Select Description Column", "Obtain Object Range", Type:=8)

Set VendorCol = Application.InputBox("Select Vendor Column", "Obtain Object Range", Type:=8)

Set FirstRow = Application.InputBox("Select First Row with Data", "Obtain Object Range", Type:=8)



'set ranges

Set DescRng = Range(Cells(FirstRow.Row, DescCol.Column), Cells(Cells(Rows.Count, DescCol.Column).End(xlUp).Row, DescCol.Column))

Set VendorRng = Range(Cells(FirstRow.Row, VendorCol.Column), Cells(Cells(Rows.Count, DescCol.Column).End(xlUp).Row, VendorCol.Column))

myVendor = VendorRng.Value2



For Each rng In DescRng



    If Cells(rng.Row, VendorCol.Column).Value = "" Then



        For j = LBound(Vendor) To UBound(Vendor)



            If InStr(1, rng.Value, Vendor(j, 2), vbTextCompare) > 0 Then

                myVendor(rng.Row - FirstRow.Row + 1, 1) = Vendor(j, 1)



        Exit For



            End If



        Next j



    End If



Next rng



VendorRng.Resize(UBound(myVendor) - LBound(myVendor) + 1, 1) = myVendor



Exit Sub



BadEntry:



msg = "You have clicked on cancel for one of the prompts."

msg = msg & vbNewLine

msg = msg & "Do you wish to try again?"

ans = MsgBox(msg, vbRetryCancel + vbExclamation)

If ans = vbRetry Then Resume TryAgain



End Sub

Thanks a lot!

Why in B3 cell is Dominos when there should be Domino's Pizza? Or I'm wrong? — Nov 18 '18 at 8:04

score 1 · Accepted Answer · 2018-11-18 12:08:45Z

1

This seems to be a simple un-pivot operation.
If you have Excel 2010+, you can use Power Query (aka Get&Transform in Excel 2016+), to do this.

Select a single cell in the table

Data / Get & Transform / From Range should select the entire table

Select the first column in the Query table.

Transform / Unpivot other columns

Delete the unwanted column

Save and Load

(Takes longer to type than to do)

This is the M Code, but you can do it all from the PQ GUI:

let

    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],

    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Column2", type text}, {"Column3", type text}, {"Column4", type text}}),

    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", {"Column1"}, "Attribute", "Value"),

    #"Removed Columns" = Table.RemoveColumns(#"Unpivoted Other Columns",{"Attribute"})

in

    #"Removed Columns"

Original Data

enter image description here

Unpivoted

enter image description here

edited Nov 18 '18 at 12:08

answered Nov 18 '18 at 12:03

Ron Rosenfeld

22.8k41636

Very nice, but it seems like it cannot be accomplished with a simple click: with VBA
– Sam
Nov 18 '18 at 12:43

Once you set up the query, you can refresh it with a single click when your data changes.
– Ron Rosenfeld
Nov 18 '18 at 12:49

Wow that's smart, it'll actually save me lines of code through VBA then... But will it update on itself, without me opening the excel file (refreshing it)?
– Sam
Nov 18 '18 at 12:51

I don't think anything within an Excel file will update if the file is closed. Are you going to be accessing your file with a non-excel program?
– Ron Rosenfeld
Nov 18 '18 at 12:52

Only with VBA to import it as a two dimensional array for use in a loop.
– Sam
Nov 18 '18 at 12:53

|
show 5 more comments

Michal Rosa 1,3161814 · Accepted Answer · 2018-11-18 03:45:47Z

I think I might have something simpler

enter image description here

Dim arr As New Collection, a

Dim var() As Variant

Dim i As Long

Dim lRows As Long, lCols As Long

Dim lRowCurrent As Long

Dim lCounter As Long



'Get the active range

Set rng = ActiveSheet.UsedRange

lRows = rng.Rows.Count

lCols = rng.Columns.Count

lRowCurrent = 0



'Loop thru every row

For i = 1 To lRows

    ' Read each line into an array

    var() = Range(Cells(i, 1), Cells(i, lCols))



    ' Create a list of unique names only

    On Error Resume Next

    For Each a In var

       arr.Add a, a

    Next



    'List all names

    lCounter = arr.Count

    For b = 1 To lCounter

        Cells(lRowCurrent + b, 7) = arr(1)

        Cells(lRowCurrent + b, 8) = arr(b)

    Next



    Set arr = Nothing

    lRowCurrent = lRowCurrent + lCounter



Next

Really nice way of doing it! Is there any way of importing what you listed into an array/collection for use as a loop? Declare another variant variable and set that variable to the listed names (range)? Thanks — Nov 18 '18 at 4:17
Thanks. Sure it's possible. And what's more - you are about to have a lot of fun figuring it out by yourself ;) Have fun. Cheers, — Nov 18 '18 at 4:22

JohnyL 3,4631822 · Accepted Answer · 2018-11-18 13:24:40Z

2

Try this:

Sub DoTranspose()

    Dim r&, cnt&

    Dim rng As Range, rngRow As Range, cell As Range

    Set rng = Sheets("Source").Range("A1").CurrentRegion

    r = 1

    For Each rngRow In rng.Rows

        cnt = WorksheetFunction.CountA(rngRow.Cells)

        With Sheets("output").Cells(r, 1).Resize(cnt)

            .Value = rngRow.Cells(1).Value

            .Offset(, 1).Value = Application.Transpose(rngRow.Resize(, cnt).Value)

        End With

        r = r + cnt

    Next

End Sub

Sample workbook.

answered Nov 18 '18 at 13:24

JohnyL

3,4631822

Nice +1 for transposition :-)
– T.M.
Nov 18 '18 at 15:14

@T.M. Thanks! 😉
– JohnyL
Nov 18 '18 at 15:49

Everything works fine with this code but it lacks the ability to remove iterations from the output, that I remove from the source. Seems like power query auto updates "better".
– Sam
Nov 19 '18 at 13:42

add a comment |

score 0 · Accepted Answer · 2018-11-19 01:34:14Z

Range Array Array Range

A Picture is Worth a Thousand Words

The left worksheet is the initial worksheet, and the right the resulting one.

Since cBlnColors is set to True, several ranges are being colored to better understand how this code works and to indicate the upsides of having headers.

The light yellow color represents the data range, while the yellow color represents the rest of the off limits cells.

All not colored cells can be used without affecting the results in the right worksheet.
cBlnHeadersBelow set to True means that the data is above the headers (unusual), while set to False would mean that the data will be below the headers (as usual).

Headers Below Data with Colors

Another Thousand

The following picture shows the same code used with cBlnHeadersBelow set to False.

The yellow range spans down to the last row (not visible).

Again, all not colored cells can be used without affecting the results in the right worksheet.

Headers Above Data with Colors

The Code

Option Explicit



'*******************************************************************************

' Purpose:    In a specified worksheet of a specified workbook, transposes a

'             range of data (vertical table!?) to a two-column range in a newly

'             created worksheet.

' Arguments (As Constants):

'   cStrFile

'     The path of the workbook file. If "", then ActiveWorkbook is used.

'   cVarWs

'     It is declared as variant to be able to use both, the title

'     (a string e.g. "Sheet1") or the index (a positive whole number e.g. 1)

'     of the worksheet. If "", then ActiveSheet is used.

'   cStrTitle

'     The contents of the first cell in the headers to be searched for.

'   cBlnHeaders

'     If True, USE headers.

'     If False, do NOT use headers i.e. cBlnHeadersBelow has no effect and the

'     first data found by searching by column from "A1" is used as first cell

'     and the last found data on the worksheet is used for last cell.

'   cBlnHeadersBelow

'     If True, the data is ABOVE the headers (Data-Then-Headers).

'     If False, the data is as usual BELOW the headers (Headers-Then-Data).

'   cStrPaste

'     The cell address of the first cell of the resulting range in the new

'     worksheet.

'   cBlnColors

'     If True, and cBlnHeaders is True, then colors are being used i.e. one

'     color for the data range, and another for off limits ranges.

'     If True, and cBlnHeaders is False, all cells are off limits,

'     so only the data range is colored.

' Returns

'   A new worksheet with resulting data. No threat to the initial worksheet.

'   If you don't like the result, just close the workbook.

'*******************************************************************************

Sub VendorFinder()



  Application.ScreenUpdating = False



'***************************************

' Variables

'***************************************

  Const cStrFile As String = ""             ' "Z:arrInit List.xlsx"

  Const cVarWs As Variant = 1               ' "" for ActiveSheet.

  Const cStrTitle As String = "Business"    ' Contents of First Cell of Header

  Const cBlnHeaders As Boolean = True       ' True for Headers

  Const cBlnHeadersBelow As Boolean = True  ' True for Headers Below Data

  Const cStrPaste As String = "A1"          ' Resulting First Cell Address

  Const cBlnColors As Boolean = True        ' Activate Colors



  Dim objWb As Workbook       ' Workbook  to be processed

  Dim objWs As Worksheet      ' Worksheet to be processed

  Dim objTitle As Range       ' First Cell of Header

  Dim objFirst As Range       ' First Cell of Data

  Dim objLast As Range        ' Last Cell of Data

  Dim objResult As Range      ' Resulting Range



  Dim arrInit As Variant      ' Array of Initial Data

  Dim arrResult() As Variant  ' Array of Resulting Data



  Dim lngRows As Long         ' Array Rows Counter

  Dim iCols As Integer        ' Array Columns Counter

  Dim lngVendor As Long       ' Array Data Counter, Array Row Counter



'            ' Debug

'            Const r1 As String = vbCr   ' Debug Rows Separator

'            Const c1 As String = ","    ' Debug Columns Separator

'

'            Dim str1 As String          ' Debug String Builder

'            Dim lng1 As Long            ' Debug Rows Counter

'            Dim i1 As Integer           ' Debug Columns Counter



'***************************************

' Workbook

'***************************************

  'On Error GoTo WorkbookErr



  If cStrFile <> "" Then

    Set objWb = Workbooks.Open(cStrFile)

   Else

    Set objWb = ActiveWorkbook

  End If



'***************************************

' Worksheet

'***************************************

  ' On Error GoTo WorksheetErr



  If cVarWs <> "" Then

    Set objWs = objWb.Worksheets(cVarWs)

   Else

    Set objWs = objWb.ActiveSheet

  End If





  With objWs



    ' Colors

    If cBlnColors = True Then

      Dim lngData As Variant: lngData = RGB(255, 255, 153)

      Dim lngOffLimits As Variant: lngOffLimits = RGB(255, 255, 0)

     Else

      .Cells.Interior.ColorIndex = xlNone

    End If



    ' Assumptions:

    '   1. Headers is a contiguous range.

    '   2. The Headers Title is the first cell of Headers i.e. the first cell

    '      where cStrTitle is found while searching by rows starting from cell

    '      "A1".

    '   3. The Headers Range spans from the Headers Title to the last cell,

    '      containing data, on the right.

    '   4. All cells to the left and to the right of the Headers Range except

    '      for the cell adjacent to the right are free to be used i.e. no

    '      calculation is performed on them. If cBlnHeadersBelow is set to True,

    '      the cells below the Headers Range are free to be used. Similarly,

    '      if cBlnHeadersBelow is set to False the cells above are free to be

    '      used.

    '   5. When cBlnHeadersBelow is set to True, the first row of data is

    '      calculated just using the column of the Headers Title

    If cBlnHeaders = True Then ' USE Headers.



      ' Calculate Headers Title (using cStrTitle as criteria).

      Set objTitle = .Cells _

          .Find(What:=cStrTitle, After:=.Cells(.Rows.Count, .Columns.Count), _

            LookIn:=xlFormulas, Lookat:=xlWhole, _

            SearchOrder:=xlByRows, SearchDirection:=xlNext)



      ' Calculate initial first and last cells of data.

      If cBlnHeadersBelow Then ' Headers are below data.



        ' Search for data in column of Headers Title starting from the first

        ' worksheet's row forwards to the row of Headers Title.

        ' When first data is found, the first cell is determined.

        Set objFirst = .Range(.Cells(1, objTitle.Column), objTitle) _

            .Find(What:="*", After:=.Cells(objTitle.Row, objTitle.Column), _

              LookIn:=xlFormulas, Lookat:=xlWhole, _

              SearchOrder:=xlByRows, SearchDirection:=xlNext)



        ' xlToRight, indicating that Headers Range is contiguous, uses the

        ' last cell of Headers Range while -1 sets the cells' row, one row above

        ' the Headers Title, resulting in the last cell range.

        Set objLast = objTitle.End(xlToRight).Offset(-1, 0)



        ' Colors

        If cBlnColors = True Then

          .Cells.Interior.ColorIndex = xlNone

          If objFirst.Row > 1 Then

            .Range(.Cells(1, objFirst.Column), _

                .Cells(objFirst.Row - 1, objLast.Column)) _

                .Interior.color = lngOffLimits

          End If

          If objLast.Column < .Columns.Count Then

            .Range(objTitle, .Cells(objTitle.Row, objLast.Column + 1)) _

                .Interior.color = lngOffLimits

           Else

            .Range(objTitle, .Cells(objTitle.Row, objLast.Column)) _

                .Interior.color = lngOffLimits

          End If

          .Range(objFirst, objLast).Interior.color = lngData

        End If



       Else ' Headers are above data (usually).



        ' 1 sets the cells' row, one row below the Headers Title

        ' resulting in the first cell range.

        Set objFirst = objTitle.Offset(1, 0)



        ' Search for data in column of Headers Title starting from the last

        ' worksheet's row backwards to the row of Headers Title.

        ' When first data is found, the last row is determined and combined

        ' with the last column results in the last cell range.

        Set objLast = .Cells( _

            .Range(objTitle, .Cells(.Rows.Count, _

              objTitle.End(xlToRight).Column)) _

            .Find(What:="*", After:=objTitle, _

              LookIn:=xlFormulas, Lookat:=xlWhole, _

              SearchOrder:=xlByRows, SearchDirection:=xlPrevious) _

            .Row, _

 _

            objTitle.End(xlToRight) _

            .Column)



        'Colors

        If cBlnColors = True Then

          .Cells.Interior.ColorIndex = xlNone

          If objLast.Row < .Rows.Count Then

            .Range(.Cells(objLast.Row + 1, objFirst.Column), _

                .Cells(.Rows.Count, objLast.Column)) _

                .Interior.color = lngOffLimits

          End If

          If objLast.Column < .Columns.Count Then

            .Range(objTitle, .Cells(objTitle.Row, objLast.Column + 1)) _

                .Interior.color = lngOffLimits

           Else

            .Range(objTitle, .Cells(objTitle.Row, objLast.Column)) _

                .Interior.color = lngOffLimits

          End If

          .Range(objFirst, objLast).Interior.color = lngData

        End If



      End If



     Else ' Do NOT use headers.



      ' Search for data in any cell from "A1" by column. When first data is

      ' found, the first cell is determined.

      Set objFirst = _

          .Cells _

          .Find(What:="*", After:=.Cells(.Rows.Count, .Columns.Count), _

          LookIn:=xlFormulas, Lookat:=xlWhole, _

          SearchOrder:=xlByColumns, SearchDirection:=xlNext)



      ' Last cell with data on the worksheet.

      Set objLast = .Cells( _

 _

          .Cells _

          .Find(What:="*", After:=.Cells(1, 1), _

          LookIn:=xlFormulas, Lookat:=xlWhole, _

          SearchOrder:=xlByRows, SearchDirection:=xlPrevious) _

          .Row, _

 _

          .Cells _

          .Find(What:="*", After:=.Cells(1, 1), _

          LookIn:=xlFormulas, Lookat:=xlWhole, _

          SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) _

          .Column)



        ' Colors

        If cBlnColors = True Then

          .Cells.Interior.ColorIndex = xlNone

          Range(objFirst, objLast).Interior.color = lngData

        End If

    End If



  End With



'***************************************

' arrInit

'***************************************

  ' On Error GoTo arrInitErr



  ' Paste the values (Value2) of initial range into initial array (arrInit).

  arrInit = Range(objFirst, objLast).Value2



'            ' Debug

'            str1 = r1 & "Initial Array (arrInit)" & r1

'            For lng1 = LBound(arrInit) To UBound(arrInit)

'              str1 = str1 & r1

'              For i1 = LBound(arrInit, 2) To UBound(arrInit, 2)

'                If i1 <> 1 Then

'                  str1 = str1 & c1

'                End If

'                str1 = str1 & arrInit(lng1, i1)

'              Next

'            Next

'            Debug.Print str1



  ' Count data in arrInit.

  For lngRows = LBound(arrInit) To UBound(arrInit)

    For iCols = LBound(arrInit, 2) To UBound(arrInit, 2)

      If arrInit(lngRows, iCols) <> "" Then

        lngVendor = lngVendor + 1

      End If

    Next

  Next



'***************************************

' arrResult

'***************************************

 ' On Error GoTo arrResultErr



  ReDim arrResult(1 To lngVendor, 1 To 2) ' Resize resulting array (arrResult).

  lngVendor = 0 ' Reset array data counter to be used as array row counter.



  ' Loop through arrInit and write to arrResult.

  For lngRows = LBound(arrInit) To UBound(arrInit)

    For iCols = LBound(arrInit, 2) To UBound(arrInit, 2)

      If arrInit(lngRows, iCols) <> "" Then

        lngVendor = lngVendor + 1

        If iCols = 1 Then

          arrResult(lngVendor, 1) = arrInit(lngRows, iCols)

         Else

          arrResult(lngVendor, 1) = arrResult(lngVendor - 1, 1)

        End If

        arrResult(lngVendor, 2) = arrInit(lngRows, iCols)

      End If

    Next

  Next

  Erase arrInit ' Data is in arrResult.



'            ' Debug

'            str1 = r1 & "Resulting Array (arrResult)" & r1

'            For lng1 = LBound(arrResult) To UBound(arrResult)

'              str1 = str1 & r1

'              For i1 = LBound(arrResult, 2) To UBound(arrResult, 2)

'                If i1 <> 1 Then

'                  str1 = str1 & c1

'                End If

'                str1 = str1 & arrResult(lng1, i1)

'              Next

'            Next

'            Debug.Print str1



' Since there is only an infinite number of possibilities what to do with the

' resulting array, pasting it into a new worksheet has been chosen to be able

' to apply the bold formatting of the "Business Names" requested.



'***************************************

' New Worksheet

'***************************************

  On Error GoTo NewWorksheetErr

  Worksheets.Add After:=objWs

  Set objResult = ActiveSheet.Range(Range(cStrPaste), _

      Range(cStrPaste).Offset(UBound(arrResult) - 1, _

      UBound(arrResult, 2) - 1))

  With objResult

    ' Paste arrResult into resulting range (objResult).

    .Value2 = arrResult

    ' Apply some formatting.

    For lngRows = LBound(arrResult) To UBound(arrResult)

'      If .Cells(lngRows, 1) = .Cells(lngRows, 2) Then ' Too slow!

      If arrResult(lngRows, 1) = arrResult(lngRows, 2) Then

        .Cells(lngRows, 1).Font.Bold = True

      End If

    Next

    Erase arrResult ' Data is in objResult.

    .Columns.AutoFit

  End With

  ' To suppress the "Do you want to save changes you made to ... ?" - Alert:

  objWb.Saved = True



'***************************************

' Clean Up

'***************************************

NewWorksheetExit:

  Set objResult = Nothing

WorksheetExit:

  Set objLast = Nothing

  Set objFirst = Nothing

  Set objTitle = Nothing

  Set objWs = Nothing

WorkbookExit:

  Set objWb = Nothing



  Application.ScreenUpdating = True



Exit Sub



'***************************************

' Errors

'***************************************

WorkbookErr:

  MsgBox "Workbook Error" & " (Error: '" & Err.Number & "')"

  GoTo WorkbookExit

WorksheetErr:

  MsgBox "Worksheet Error" & " (Error: '" & Err.Number & "')"

  GoTo WorksheetExit

arrInitErr:

  MsgBox "arrInit Error" & " (Error: '" & Err.Number & "')"

  GoTo WorksheetExit

arrResultErr:

  MsgBox "arrResult Error" & " (Error: '" & Err.Number & "')"

  GoTo WorksheetExit

NewWorksheetErr:

  MsgBox "New Worksheet Error" & " (Error: '" & Err.Number & "')"

  GoTo NewWorksheetExit



End Sub

'*******************************************************************************

Extras

While testing the code, there were a little too many many worksheets in the workbook so I wrote this:

'*******************************************************************************

' Purpose:  Deletes all Worksheets in the ActiveWorkbook except one.

' Danger:   This code doesn't ask anything, it just does. In the end you will

'           end up with just one worksheet (cStrWsExcept) in the workbook

'           (cStrWbPath). If you have executed this code and the result is not

'           satisfactory, just close the workbook and try again or don't. There

'           will be no alert like "Do you want to save ..." because of the line:

'           ".Saved = True" i.e. "objWb.Saved = True".

' Arguments (As Constants):

'   cStrWbPath

'     The path of the workbook to be processed. If "", then ActiveWorkbook is

'     used.

'   cStrWsExcept

'     The worksheet not to be deleted. If "", then the Activesheet is used.

'*******************************************************************************

Sub DeleteWorksheetsExceptOne()



  Const cStrWbPath = ""          ' if "" then ActiveWorkbook

  Const cStrWsExcept = "Sheet1"  ' if "" then ActiveSheet



  Dim objWb As Workbook

  Dim objWsExcept As Worksheet

  Dim objWsDelete As Worksheet



  If cStrWbPath = "" Then

    Set objWb = ActiveWorkbook

   Else

    Set objWb = Workbooks(cStrWbPath)

  End If



  With objWb

    If cStrWsExcept = "" Then

      Set objWsExcept = .ActiveSheet

     Else

      Set objWsExcept = .Worksheets(cStrWsExcept)

    End If



    ' To suppress the "Data may exist in the sheet(s) selected for deletion.

    '                  To permanently delete the data, press Delete." - Alert:

    Application.DisplayAlerts = False



      For Each objWsDelete In .Worksheets

        If objWsDelete.Name <> objWsExcept.Name Then

          objWsDelete.Delete

        End If

      Next



      ' To suppress the "Do you want to save changes you made to ... ?" - Alert:

      .Saved = True



    Application.DisplayAlerts = True



  End With



End Sub

'*******************************************************************************

score 1 · Accepted Answer · 2018-11-18 12:08:45Z

1

This seems to be a simple un-pivot operation.
If you have Excel 2010+, you can use Power Query (aka Get&Transform in Excel 2016+), to do this.

Select a single cell in the table

Data / Get & Transform / From Range should select the entire table

Select the first column in the Query table.

Transform / Unpivot other columns

Delete the unwanted column

Save and Load

(Takes longer to type than to do)

This is the M Code, but you can do it all from the PQ GUI:

let

    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],

    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Column2", type text}, {"Column3", type text}, {"Column4", type text}}),

    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", {"Column1"}, "Attribute", "Value"),

    #"Removed Columns" = Table.RemoveColumns(#"Unpivoted Other Columns",{"Attribute"})

in

    #"Removed Columns"

Original Data

enter image description here

Unpivoted

enter image description here

edited Nov 18 '18 at 12:08

answered Nov 18 '18 at 12:03

Ron Rosenfeld

22.8k41636

Very nice, but it seems like it cannot be accomplished with a simple click: with VBA
– Sam
Nov 18 '18 at 12:43

Once you set up the query, you can refresh it with a single click when your data changes.
– Ron Rosenfeld
Nov 18 '18 at 12:49

Wow that's smart, it'll actually save me lines of code through VBA then... But will it update on itself, without me opening the excel file (refreshing it)?
– Sam
Nov 18 '18 at 12:51

I don't think anything within an Excel file will update if the file is closed. Are you going to be accessing your file with a non-excel program?
– Ron Rosenfeld
Nov 18 '18 at 12:52

Only with VBA to import it as a two dimensional array for use in a loop.
– Sam
Nov 18 '18 at 12:53

|
show 5 more comments

Michal Rosa 1,3161814 · Accepted Answer · 2018-11-18 03:45:47Z

I think I might have something simpler

enter image description here

Dim arr As New Collection, a

Dim var() As Variant

Dim i As Long

Dim lRows As Long, lCols As Long

Dim lRowCurrent As Long

Dim lCounter As Long



'Get the active range

Set rng = ActiveSheet.UsedRange

lRows = rng.Rows.Count

lCols = rng.Columns.Count

lRowCurrent = 0



'Loop thru every row

For i = 1 To lRows

    ' Read each line into an array

    var() = Range(Cells(i, 1), Cells(i, lCols))



    ' Create a list of unique names only

    On Error Resume Next

    For Each a In var

       arr.Add a, a

    Next



    'List all names

    lCounter = arr.Count

    For b = 1 To lCounter

        Cells(lRowCurrent + b, 7) = arr(1)

        Cells(lRowCurrent + b, 8) = arr(b)

    Next



    Set arr = Nothing

    lRowCurrent = lRowCurrent + lCounter



Next

Really nice way of doing it! Is there any way of importing what you listed into an array/collection for use as a loop? Declare another variant variable and set that variable to the listed names (range)? Thanks — Nov 18 '18 at 4:17
Thanks. Sure it's possible. And what's more - you are about to have a lot of fun figuring it out by yourself ;) Have fun. Cheers, — Nov 18 '18 at 4:22

JohnyL 3,4631822 · Accepted Answer · 2018-11-18 13:24:40Z

2

Try this:

Sub DoTranspose()

    Dim r&, cnt&

    Dim rng As Range, rngRow As Range, cell As Range

    Set rng = Sheets("Source").Range("A1").CurrentRegion

    r = 1

    For Each rngRow In rng.Rows

        cnt = WorksheetFunction.CountA(rngRow.Cells)

        With Sheets("output").Cells(r, 1).Resize(cnt)

            .Value = rngRow.Cells(1).Value

            .Offset(, 1).Value = Application.Transpose(rngRow.Resize(, cnt).Value)

        End With

        r = r + cnt

    Next

End Sub

Sample workbook.

answered Nov 18 '18 at 13:24

JohnyL

3,4631822

Nice +1 for transposition :-)
– T.M.
Nov 18 '18 at 15:14

@T.M. Thanks! 😉
– JohnyL
Nov 18 '18 at 15:49

Everything works fine with this code but it lacks the ability to remove iterations from the output, that I remove from the source. Seems like power query auto updates "better".
– Sam
Nov 19 '18 at 13:42

add a comment |

score 0 · Accepted Answer · 2018-11-19 01:34:14Z

Range Array Array Range

A Picture is Worth a Thousand Words

The left worksheet is the initial worksheet, and the right the resulting one.

Since cBlnColors is set to True, several ranges are being colored to better understand how this code works and to indicate the upsides of having headers.

The light yellow color represents the data range, while the yellow color represents the rest of the off limits cells.

All not colored cells can be used without affecting the results in the right worksheet.
cBlnHeadersBelow set to True means that the data is above the headers (unusual), while set to False would mean that the data will be below the headers (as usual).

Headers Below Data with Colors

Another Thousand

The following picture shows the same code used with cBlnHeadersBelow set to False.

The yellow range spans down to the last row (not visible).

Again, all not colored cells can be used without affecting the results in the right worksheet.

Headers Above Data with Colors

The Code

Option Explicit



'*******************************************************************************

' Purpose:    In a specified worksheet of a specified workbook, transposes a

'             range of data (vertical table!?) to a two-column range in a newly

'             created worksheet.

' Arguments (As Constants):

'   cStrFile

'     The path of the workbook file. If "", then ActiveWorkbook is used.

'   cVarWs

'     It is declared as variant to be able to use both, the title

'     (a string e.g. "Sheet1") or the index (a positive whole number e.g. 1)

'     of the worksheet. If "", then ActiveSheet is used.

'   cStrTitle

'     The contents of the first cell in the headers to be searched for.

'   cBlnHeaders

'     If True, USE headers.

'     If False, do NOT use headers i.e. cBlnHeadersBelow has no effect and the

'     first data found by searching by column from "A1" is used as first cell

'     and the last found data on the worksheet is used for last cell.

'   cBlnHeadersBelow

'     If True, the data is ABOVE the headers (Data-Then-Headers).

'     If False, the data is as usual BELOW the headers (Headers-Then-Data).

'   cStrPaste

'     The cell address of the first cell of the resulting range in the new

'     worksheet.

'   cBlnColors

'     If True, and cBlnHeaders is True, then colors are being used i.e. one

'     color for the data range, and another for off limits ranges.

'     If True, and cBlnHeaders is False, all cells are off limits,

'     so only the data range is colored.

' Returns

'   A new worksheet with resulting data. No threat to the initial worksheet.

'   If you don't like the result, just close the workbook.

'*******************************************************************************

Sub VendorFinder()



  Application.ScreenUpdating = False



'***************************************

' Variables

'***************************************

  Const cStrFile As String = ""             ' "Z:arrInit List.xlsx"

  Const cVarWs As Variant = 1               ' "" for ActiveSheet.

  Const cStrTitle As String = "Business"    ' Contents of First Cell of Header

  Const cBlnHeaders As Boolean = True       ' True for Headers

  Const cBlnHeadersBelow As Boolean = True  ' True for Headers Below Data

  Const cStrPaste As String = "A1"          ' Resulting First Cell Address

  Const cBlnColors As Boolean = True        ' Activate Colors



  Dim objWb As Workbook       ' Workbook  to be processed

  Dim objWs As Worksheet      ' Worksheet to be processed

  Dim objTitle As Range       ' First Cell of Header

  Dim objFirst As Range       ' First Cell of Data

  Dim objLast As Range        ' Last Cell of Data

  Dim objResult As Range      ' Resulting Range



  Dim arrInit As Variant      ' Array of Initial Data

  Dim arrResult() As Variant  ' Array of Resulting Data



  Dim lngRows As Long         ' Array Rows Counter

  Dim iCols As Integer        ' Array Columns Counter

  Dim lngVendor As Long       ' Array Data Counter, Array Row Counter



'            ' Debug

'            Const r1 As String = vbCr   ' Debug Rows Separator

'            Const c1 As String = ","    ' Debug Columns Separator

'

'            Dim str1 As String          ' Debug String Builder

'            Dim lng1 As Long            ' Debug Rows Counter

'            Dim i1 As Integer           ' Debug Columns Counter



'***************************************

' Workbook

'***************************************

  'On Error GoTo WorkbookErr



  If cStrFile <> "" Then

    Set objWb = Workbooks.Open(cStrFile)

   Else

    Set objWb = ActiveWorkbook

  End If



'***************************************

' Worksheet

'***************************************

  ' On Error GoTo WorksheetErr



  If cVarWs <> "" Then

    Set objWs = objWb.Worksheets(cVarWs)

   Else

    Set objWs = objWb.ActiveSheet

  End If





  With objWs



    ' Colors

    If cBlnColors = True Then

      Dim lngData As Variant: lngData = RGB(255, 255, 153)

      Dim lngOffLimits As Variant: lngOffLimits = RGB(255, 255, 0)

     Else

      .Cells.Interior.ColorIndex = xlNone

    End If



    ' Assumptions:

    '   1. Headers is a contiguous range.

    '   2. The Headers Title is the first cell of Headers i.e. the first cell

    '      where cStrTitle is found while searching by rows starting from cell

    '      "A1".

    '   3. The Headers Range spans from the Headers Title to the last cell,

    '      containing data, on the right.

    '   4. All cells to the left and to the right of the Headers Range except

    '      for the cell adjacent to the right are free to be used i.e. no

    '      calculation is performed on them. If cBlnHeadersBelow is set to True,

    '      the cells below the Headers Range are free to be used. Similarly,

    '      if cBlnHeadersBelow is set to False the cells above are free to be

    '      used.

    '   5. When cBlnHeadersBelow is set to True, the first row of data is

    '      calculated just using the column of the Headers Title

    If cBlnHeaders = True Then ' USE Headers.



      ' Calculate Headers Title (using cStrTitle as criteria).

      Set objTitle = .Cells _

          .Find(What:=cStrTitle, After:=.Cells(.Rows.Count, .Columns.Count), _

            LookIn:=xlFormulas, Lookat:=xlWhole, _

            SearchOrder:=xlByRows, SearchDirection:=xlNext)



      ' Calculate initial first and last cells of data.

      If cBlnHeadersBelow Then ' Headers are below data.



        ' Search for data in column of Headers Title starting from the first

        ' worksheet's row forwards to the row of Headers Title.

        ' When first data is found, the first cell is determined.

        Set objFirst = .Range(.Cells(1, objTitle.Column), objTitle) _

            .Find(What:="*", After:=.Cells(objTitle.Row, objTitle.Column), _

              LookIn:=xlFormulas, Lookat:=xlWhole, _

              SearchOrder:=xlByRows, SearchDirection:=xlNext)



        ' xlToRight, indicating that Headers Range is contiguous, uses the

        ' last cell of Headers Range while -1 sets the cells' row, one row above

        ' the Headers Title, resulting in the last cell range.

        Set objLast = objTitle.End(xlToRight).Offset(-1, 0)



        ' Colors

        If cBlnColors = True Then

          .Cells.Interior.ColorIndex = xlNone

          If objFirst.Row > 1 Then

            .Range(.Cells(1, objFirst.Column), _

                .Cells(objFirst.Row - 1, objLast.Column)) _

                .Interior.color = lngOffLimits

          End If

          If objLast.Column < .Columns.Count Then

            .Range(objTitle, .Cells(objTitle.Row, objLast.Column + 1)) _

                .Interior.color = lngOffLimits

           Else

            .Range(objTitle, .Cells(objTitle.Row, objLast.Column)) _

                .Interior.color = lngOffLimits

          End If

          .Range(objFirst, objLast).Interior.color = lngData

        End If



       Else ' Headers are above data (usually).



        ' 1 sets the cells' row, one row below the Headers Title

        ' resulting in the first cell range.

        Set objFirst = objTitle.Offset(1, 0)



        ' Search for data in column of Headers Title starting from the last

        ' worksheet's row backwards to the row of Headers Title.

        ' When first data is found, the last row is determined and combined

        ' with the last column results in the last cell range.

        Set objLast = .Cells( _

            .Range(objTitle, .Cells(.Rows.Count, _

              objTitle.End(xlToRight).Column)) _

            .Find(What:="*", After:=objTitle, _

              LookIn:=xlFormulas, Lookat:=xlWhole, _

              SearchOrder:=xlByRows, SearchDirection:=xlPrevious) _

            .Row, _

 _

            objTitle.End(xlToRight) _

            .Column)



        'Colors

        If cBlnColors = True Then

          .Cells.Interior.ColorIndex = xlNone

          If objLast.Row < .Rows.Count Then

            .Range(.Cells(objLast.Row + 1, objFirst.Column), _

                .Cells(.Rows.Count, objLast.Column)) _

                .Interior.color = lngOffLimits

          End If

          If objLast.Column < .Columns.Count Then

            .Range(objTitle, .Cells(objTitle.Row, objLast.Column + 1)) _

                .Interior.color = lngOffLimits

           Else

            .Range(objTitle, .Cells(objTitle.Row, objLast.Column)) _

                .Interior.color = lngOffLimits

          End If

          .Range(objFirst, objLast).Interior.color = lngData

        End If



      End If



     Else ' Do NOT use headers.



      ' Search for data in any cell from "A1" by column. When first data is

      ' found, the first cell is determined.

      Set objFirst = _

          .Cells _

          .Find(What:="*", After:=.Cells(.Rows.Count, .Columns.Count), _

          LookIn:=xlFormulas, Lookat:=xlWhole, _

          SearchOrder:=xlByColumns, SearchDirection:=xlNext)



      ' Last cell with data on the worksheet.

      Set objLast = .Cells( _

 _

          .Cells _

          .Find(What:="*", After:=.Cells(1, 1), _

          LookIn:=xlFormulas, Lookat:=xlWhole, _

          SearchOrder:=xlByRows, SearchDirection:=xlPrevious) _

          .Row, _

 _

          .Cells _

          .Find(What:="*", After:=.Cells(1, 1), _

          LookIn:=xlFormulas, Lookat:=xlWhole, _

          SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) _

          .Column)



        ' Colors

        If cBlnColors = True Then

          .Cells.Interior.ColorIndex = xlNone

          Range(objFirst, objLast).Interior.color = lngData

        End If

    End If



  End With



'***************************************

' arrInit

'***************************************

  ' On Error GoTo arrInitErr



  ' Paste the values (Value2) of initial range into initial array (arrInit).

  arrInit = Range(objFirst, objLast).Value2



'            ' Debug

'            str1 = r1 & "Initial Array (arrInit)" & r1

'            For lng1 = LBound(arrInit) To UBound(arrInit)

'              str1 = str1 & r1

'              For i1 = LBound(arrInit, 2) To UBound(arrInit, 2)

'                If i1 <> 1 Then

'                  str1 = str1 & c1

'                End If

'                str1 = str1 & arrInit(lng1, i1)

'              Next

'            Next

'            Debug.Print str1



  ' Count data in arrInit.

  For lngRows = LBound(arrInit) To UBound(arrInit)

    For iCols = LBound(arrInit, 2) To UBound(arrInit, 2)

      If arrInit(lngRows, iCols) <> "" Then

        lngVendor = lngVendor + 1

      End If

    Next

  Next



'***************************************

' arrResult

'***************************************

 ' On Error GoTo arrResultErr



  ReDim arrResult(1 To lngVendor, 1 To 2) ' Resize resulting array (arrResult).

  lngVendor = 0 ' Reset array data counter to be used as array row counter.



  ' Loop through arrInit and write to arrResult.

  For lngRows = LBound(arrInit) To UBound(arrInit)

    For iCols = LBound(arrInit, 2) To UBound(arrInit, 2)

      If arrInit(lngRows, iCols) <> "" Then

        lngVendor = lngVendor + 1

        If iCols = 1 Then

          arrResult(lngVendor, 1) = arrInit(lngRows, iCols)

         Else

          arrResult(lngVendor, 1) = arrResult(lngVendor - 1, 1)

        End If

        arrResult(lngVendor, 2) = arrInit(lngRows, iCols)

      End If

    Next

  Next

  Erase arrInit ' Data is in arrResult.



'            ' Debug

'            str1 = r1 & "Resulting Array (arrResult)" & r1

'            For lng1 = LBound(arrResult) To UBound(arrResult)

'              str1 = str1 & r1

'              For i1 = LBound(arrResult, 2) To UBound(arrResult, 2)

'                If i1 <> 1 Then

'                  str1 = str1 & c1

'                End If

'                str1 = str1 & arrResult(lng1, i1)

'              Next

'            Next

'            Debug.Print str1



' Since there is only an infinite number of possibilities what to do with the

' resulting array, pasting it into a new worksheet has been chosen to be able

' to apply the bold formatting of the "Business Names" requested.



'***************************************

' New Worksheet

'***************************************

  On Error GoTo NewWorksheetErr

  Worksheets.Add After:=objWs

  Set objResult = ActiveSheet.Range(Range(cStrPaste), _

      Range(cStrPaste).Offset(UBound(arrResult) - 1, _

      UBound(arrResult, 2) - 1))

  With objResult

    ' Paste arrResult into resulting range (objResult).

    .Value2 = arrResult

    ' Apply some formatting.

    For lngRows = LBound(arrResult) To UBound(arrResult)

'      If .Cells(lngRows, 1) = .Cells(lngRows, 2) Then ' Too slow!

      If arrResult(lngRows, 1) = arrResult(lngRows, 2) Then

        .Cells(lngRows, 1).Font.Bold = True

      End If

    Next

    Erase arrResult ' Data is in objResult.

    .Columns.AutoFit

  End With

  ' To suppress the "Do you want to save changes you made to ... ?" - Alert:

  objWb.Saved = True



'***************************************

' Clean Up

'***************************************

NewWorksheetExit:

  Set objResult = Nothing

WorksheetExit:

  Set objLast = Nothing

  Set objFirst = Nothing

  Set objTitle = Nothing

  Set objWs = Nothing

WorkbookExit:

  Set objWb = Nothing



  Application.ScreenUpdating = True



Exit Sub



'***************************************

' Errors

'***************************************

WorkbookErr:

  MsgBox "Workbook Error" & " (Error: '" & Err.Number & "')"

  GoTo WorkbookExit

WorksheetErr:

  MsgBox "Worksheet Error" & " (Error: '" & Err.Number & "')"

  GoTo WorksheetExit

arrInitErr:

  MsgBox "arrInit Error" & " (Error: '" & Err.Number & "')"

  GoTo WorksheetExit

arrResultErr:

  MsgBox "arrResult Error" & " (Error: '" & Err.Number & "')"

  GoTo WorksheetExit

NewWorksheetErr:

  MsgBox "New Worksheet Error" & " (Error: '" & Err.Number & "')"

  GoTo NewWorksheetExit



End Sub

'*******************************************************************************

Extras

While testing the code, there were a little too many many worksheets in the workbook so I wrote this:

'*******************************************************************************

' Purpose:  Deletes all Worksheets in the ActiveWorkbook except one.

' Danger:   This code doesn't ask anything, it just does. In the end you will

'           end up with just one worksheet (cStrWsExcept) in the workbook

'           (cStrWbPath). If you have executed this code and the result is not

'           satisfactory, just close the workbook and try again or don't. There

'           will be no alert like "Do you want to save ..." because of the line:

'           ".Saved = True" i.e. "objWb.Saved = True".

' Arguments (As Constants):

'   cStrWbPath

'     The path of the workbook to be processed. If "", then ActiveWorkbook is

'     used.

'   cStrWsExcept

'     The worksheet not to be deleted. If "", then the Activesheet is used.

'*******************************************************************************

Sub DeleteWorksheetsExceptOne()



  Const cStrWbPath = ""          ' if "" then ActiveWorkbook

  Const cStrWsExcept = "Sheet1"  ' if "" then ActiveSheet



  Dim objWb As Workbook

  Dim objWsExcept As Worksheet

  Dim objWsDelete As Worksheet



  If cStrWbPath = "" Then

    Set objWb = ActiveWorkbook

   Else

    Set objWb = Workbooks(cStrWbPath)

  End If



  With objWb

    If cStrWsExcept = "" Then

      Set objWsExcept = .ActiveSheet

     Else

      Set objWsExcept = .Worksheets(cStrWsExcept)

    End If



    ' To suppress the "Data may exist in the sheet(s) selected for deletion.

    '                  To permanently delete the data, press Delete." - Alert:

    Application.DisplayAlerts = False



      For Each objWsDelete In .Worksheets

        If objWsDelete.Name <> objWsExcept.Name Then

          objWsDelete.Delete

        End If

      Next



      ' To suppress the "Do you want to save changes you made to ... ?" - Alert:

      .Saved = True



    Application.DisplayAlerts = True



  End With



End Sub

'*******************************************************************************

Import variable range into Array/Collection?

4 Answers 4

Original Data

Unpivoted

Range Array Array Range

A Picture is Worth a Thousand Words

Another Thousand

The Code

Extras

Your Answer

Sign up or log in

Post as a guest

Post as a guest

4 Answers 4

4 Answers 4

Original Data

Unpivoted

Original Data

Unpivoted

Original Data

Unpivoted

Original Data

Unpivoted

Range Array Array Range

A Picture is Worth a Thousand Words

Another Thousand

The Code

Extras

Range Array Array Range

A Picture is Worth a Thousand Words

Another Thousand

The Code

Extras

Range Array Array Range

A Picture is Worth a Thousand Words

Another Thousand

The Code

Extras

Range Array Array Range

A Picture is Worth a Thousand Words

Another Thousand

The Code

Extras

Sign up or log in

Post as a guest

Post as a guest

Sign up or log in

Post as a guest

Sign up or log in

Post as a guest

Sign up or log in

Post as a guest

Popular posts from this blog

Biblatex bibliography style without URLs when DOI exists (in Overleaf with Zotero bibliography)

ComboBox Display Member on multiple fields

Is it possible to collect Nectar points via Trainline?

4 Answers
4

4 Answers
4

4 Answers
4