Import variable range into Array/Collection?












1














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



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!










share|improve this question






















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










  • @JohnyL You're completely right. There's a mistake.
    – Sam
    Nov 18 '18 at 12:41
















1














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



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!










share|improve this question






















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










  • @JohnyL You're completely right. There's a mistake.
    – Sam
    Nov 18 '18 at 12:41














1












1








1


1





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



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!










share|improve this question













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



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!







excel vba excel-vba






share|improve this question













share|improve this question











share|improve this question




share|improve this question










asked Nov 18 '18 at 1:47









Sam

808




808












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










  • @JohnyL You're completely right. There's a mistake.
    – Sam
    Nov 18 '18 at 12:41


















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










  • @JohnyL You're completely right. There's a mistake.
    – Sam
    Nov 18 '18 at 12:41
















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




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












@JohnyL You're completely right. There's a mistake.
– Sam
Nov 18 '18 at 12:41




@JohnyL You're completely right. There's a mistake.
– Sam
Nov 18 '18 at 12:41












4 Answers
4






active

oldest

votes


















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






share|improve this answer























  • 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



















2














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





share|improve this answer





















  • 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
    – Sam
    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,
    – Michal Rosa
    Nov 18 '18 at 4:22



















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.






share|improve this answer





















  • 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



















0














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
'*******************************************************************************





share|improve this answer























    Your Answer






    StackExchange.ifUsing("editor", function () {
    StackExchange.using("externalEditor", function () {
    StackExchange.using("snippets", function () {
    StackExchange.snippets.init();
    });
    });
    }, "code-snippets");

    StackExchange.ready(function() {
    var channelOptions = {
    tags: "".split(" "),
    id: "1"
    };
    initTagRenderer("".split(" "), "".split(" "), channelOptions);

    StackExchange.using("externalEditor", function() {
    // Have to fire editor after snippets, if snippets enabled
    if (StackExchange.settings.snippets.snippetsEnabled) {
    StackExchange.using("snippets", function() {
    createEditor();
    });
    }
    else {
    createEditor();
    }
    });

    function createEditor() {
    StackExchange.prepareEditor({
    heartbeatType: 'answer',
    autoActivateHeartbeat: false,
    convertImagesToLinks: true,
    noModals: true,
    showLowRepImageUploadWarning: true,
    reputationToPostImages: 10,
    bindNavPrevention: true,
    postfix: "",
    imageUploader: {
    brandingHtml: "Powered by u003ca class="icon-imgur-white" href="https://imgur.com/"u003eu003c/au003e",
    contentPolicyHtml: "User contributions licensed under u003ca href="https://creativecommons.org/licenses/by-sa/3.0/"u003ecc by-sa 3.0 with attribution requiredu003c/au003e u003ca href="https://stackoverflow.com/legal/content-policy"u003e(content policy)u003c/au003e",
    allowUrls: true
    },
    onDemand: true,
    discardSelector: ".discard-answer"
    ,immediatelyShowMarkdownHelp:true
    });


    }
    });














    draft saved

    draft discarded


















    StackExchange.ready(
    function () {
    StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fstackoverflow.com%2fquestions%2f53357214%2fimport-variable-range-into-array-collection%23new-answer', 'question_page');
    }
    );

    Post as a guest















    Required, but never shown

























    4 Answers
    4






    active

    oldest

    votes








    4 Answers
    4






    active

    oldest

    votes









    active

    oldest

    votes






    active

    oldest

    votes









    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






    share|improve this answer























    • 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
















    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






    share|improve this answer























    • 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














    1












    1








    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






    share|improve this answer














    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







    share|improve this answer














    share|improve this answer



    share|improve this answer








    edited Nov 18 '18 at 12:08

























    answered Nov 18 '18 at 12:03









    Ron Rosenfeld

    22.8k41636




    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


















    • 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
















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




    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




    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






    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




    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




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













    2














    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





    share|improve this answer





















    • 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
      – Sam
      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,
      – Michal Rosa
      Nov 18 '18 at 4:22
















    2














    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





    share|improve this answer





















    • 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
      – Sam
      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,
      – Michal Rosa
      Nov 18 '18 at 4:22














    2












    2








    2






    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





    share|improve this answer












    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






    share|improve this answer












    share|improve this answer



    share|improve this answer










    answered Nov 18 '18 at 3:45









    Michal Rosa

    1,3161814




    1,3161814












    • 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
      – Sam
      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,
      – Michal Rosa
      Nov 18 '18 at 4:22


















    • 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
      – Sam
      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,
      – Michal Rosa
      Nov 18 '18 at 4:22
















    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
    – Sam
    Nov 18 '18 at 4:17




    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
    – Sam
    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,
    – Michal Rosa
    Nov 18 '18 at 4:22




    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,
    – Michal Rosa
    Nov 18 '18 at 4:22











    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.






    share|improve this answer





















    • 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
















    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.






    share|improve this answer





















    • 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














    2












    2








    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.






    share|improve this answer












    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.







    share|improve this answer












    share|improve this answer



    share|improve this answer










    answered Nov 18 '18 at 13:24









    JohnyL

    3,4631822




    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


















    • 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
















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




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












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




    @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




    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











    0














    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
    '*******************************************************************************





    share|improve this answer




























      0














      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
      '*******************************************************************************





      share|improve this answer


























        0












        0








        0






        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
        '*******************************************************************************





        share|improve this answer














        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
        '*******************************************************************************






        share|improve this answer














        share|improve this answer



        share|improve this answer








        edited Nov 19 '18 at 1:34

























        answered Nov 18 '18 at 13:16









        VBasic2008

        1,7892213




        1,7892213






























            draft saved

            draft discarded




















































            Thanks for contributing an answer to Stack Overflow!


            • Please be sure to answer the question. Provide details and share your research!

            But avoid



            • Asking for help, clarification, or responding to other answers.

            • Making statements based on opinion; back them up with references or personal experience.


            To learn more, see our tips on writing great answers.





            Some of your past answers have not been well-received, and you're in danger of being blocked from answering.


            Please pay close attention to the following guidance:


            • Please be sure to answer the question. Provide details and share your research!

            But avoid



            • Asking for help, clarification, or responding to other answers.

            • Making statements based on opinion; back them up with references or personal experience.


            To learn more, see our tips on writing great answers.




            draft saved


            draft discarded














            StackExchange.ready(
            function () {
            StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fstackoverflow.com%2fquestions%2f53357214%2fimport-variable-range-into-array-collection%23new-answer', 'question_page');
            }
            );

            Post as a guest















            Required, but never shown





















































            Required, but never shown














            Required, but never shown












            Required, but never shown







            Required, but never shown

































            Required, but never shown














            Required, but never shown












            Required, but never shown







            Required, but never shown







            Popular posts from this blog

            How to change which sound is reproduced for terminal bell?

            Title Spacing in Bjornstrup Chapter, Removing Chapter Number From Contents

            Can I use Tabulator js library in my java Spring + Thymeleaf project?