范围数组数组范围

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

Answer 2

尝试一下：

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

示例workbook。

Answer 3

这似乎是一个简单的un-pivot操作。如果您拥有Excel 2010+，则可以使用Power Query（在Excel 2016+中也称为Get&Transform）。

在表格中选择一个单元格
数据/获取和转换/从范围中应选择整个表格
选择查询表中的第一列。
转换/取消其他列
删除不需要的列
保存并加载

（输入时间比输入时间长）

这是M代码，但是您可以在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"

原始数据

无误

Answer 4

范围数组数组范围

图片值得一千个字

左侧工作表是初始工作表，右侧是结果工作表。
由于 cBlnColors 设置为 True ，因此对多个范围进行了着色，以更好地理解此代码的工作方式并指出具有标头的上部。 br /> 浅黄色颜色表示数据范围，而黄色颜色表示其余的禁区单元格。
可以使用所有未着色的单元格，而不会影响正确的工作表中的结果。
将 cBlnHeadersBelow 设置为 True 表示数据位于标题上方（不正常），而设置为 False 则表示数据将位于标题下方（通常）。

Headers Below Data with Colors

另一千

下图显示了相同的代码，其中 cBlnHeadersBelow 设置为 False 。
黄色范围延伸到最后一行（不可见）。
同样，可以使用所有未着色的单元格，而不会影响正确的工作表中的结果。

Headers Above Data with Colors

代码

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

其他

在测试代码时，工作簿中有一些工作表太多，所以我这样写：

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

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

4 个答案:

原始数据

无误

范围数组数组范围

图片值得一千个字

另一千

代码

其他