excel - 将变量范围导入数组/集合？

Question

有什么方法可以导入如下所示的范围:


我正在尝试导入行数和列数不确定的范围。如第 5 行所示，我希望导入的范围在第一列业务名称及其后续列中具有同一业务的不同迭代。

我一直在考虑使用数组，但我看不到它是可能的，因为每个元素我会有不同的尺寸(例如，加拿大轮胎为 3 个尺寸，梅赛德斯为 2 个尺寸)。

我也考虑过使用集合/字典，但我在使用和理解它们时偶然发现。

最终，我的意图是在列中循环该范围内的迭代，如果这些迭代中的任何一个与我列中的单元格匹配，则在偏移单元格中写入第一次迭代(业务名称以粗体显示)。

现在，我知道，我可以从这样的范围内做一个二维数组，重复第一次迭代(企业名称):



但是，重写企业名称非常麻烦。
下面是我用于二维数组的代码:

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

非常感谢!

Answer 1

我想我可能有更简单的东西

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