Question

也许我只是没有找到合适的地方，但我认为这不应该像我发现的那样困难。

我有一个电子表格，无法进行排序（它位于生产线上，连接到带有其他数据的单张纸张，由许多不同的人填写）。进来的数据基本上是随机的，如下所示：

''    Type    Sieve #40
''
''    Truck       55%
''    Truck       55%
''    CoA         48%
''    Basement    55%
''    Bin2        55%
''    Bin1        55%
''    Hopper      57%
''    Basement    58%
''    Bin2        54%
''    Bin1        58%
''    Hopper      56%
''    Truck       56%
''    CoA         47%
''    Basement    55%
''    Bin2        57%
''    Bin1        61%
''    Hopper      50%

现在，我需要一个可以找到样本类型（truck，bin1等）的宏，并将与该样本类型对应的每个值放入一个范围内。然后我可以在图表上绘制范围。

例如，“卡车”范围的数字为55％，55％，56％。

因此，有6种不同的样本类型，这意味着6个不同的范围，这意味着我的图表上有6个不同的系列。

我已经编写了所有代码来绘制图表，并编写了所有代码以将数据收集到这两列中。我只是错过了这篇文章。

理想情况下，例如，有一种方法可以设置从第1行到最后一行的For循环，当它找到“truck”时，它会在“next”旁边的列中分配数字。卡车“到新阵列的第一个位置。然后下一个“卡车”实例填充“卡车”阵列中的下一个点，依此类推。

添加工作表对我来说几乎是不可能的，因为操作员必须为每个样本添加一个新工作表，然后将一些数据提取到此汇总表中。

Answer 1

我将数据集复制到空白工作簿的Sheet1中，将文本用于列，确保Sheet2＆amp; Sheet3存在，并使用此代码将其拆分。您可以根据自己的需要进行返工。本质上，我将数据集设置为一个数组，将值循环到每个类型的单独数组中，然后将每个数组加载到一个打印数组中。打印数组与value2维度匹配。中间数组是锯齿状的，因为你不能redim preserve多维数组。

Sub SplitSet()
  Dim vInput() As Variant, vTruck() As Variant, vHopper() As Variant, vPrint() As Variant
  Dim l As Long

  'Get values into array
  vInput = Sheet1.UsedRange.Value2

  'Loop through array and load type arrays
  ReDim vTruck(1 To 1)
  ReDim vHopper(1 To 1)
  For l = 1 To UBound(vInput)
    Select Case vInput(l, 2)
      Case "Truck"
        If IsEmpty(vTruck(1)) = False Then ReDim Preserve vTruck(1 To UBound(vTruck) + 1)
        vTruck(UBound(vTruck)) = Array(vInput(l, 2), vInput(l, 3))
      Case "Hopper"
        If IsEmpty(vHopper(1)) = False Then ReDim Preserve vHopper(1 To UBound(vHopper) + 1)
        vHopper(UBound(vHopper)) = Array(vInput(l, 2), vInput(l, 3))
    End Select
  Next l

  'Print
  vPrint = TypeArrayToPrintArray(vTruck)
  Sheet2.Activate
  Sheet2.Range(Cells(1, 1), Cells(UBound(vPrint), 2)).Value2 = vPrint

  vPrint = TypeArrayToPrintArray(vHopper)
  Sheet3.Activate
  Sheet3.Range(Cells(1, 1), Cells(UBound(vPrint), 2)).Value2 = vPrint
End Sub

Function TypeArrayToPrintArray(ByRef vArray() As Variant) As Variant()
  Dim vPrint() As Variant
  Dim l As Long
  ReDim vPrint(1 To UBound(vArray), 1 To 2)
  For l = 1 To UBound(vArray)
    vPrint(l, 1) = vArray(l)(0)
    vPrint(l, 2) = vArray(l)(1)
  Next l

  TypeArrayToPrintArray = vPrint
End Function

Answer 2

根据OP的最后澄清

已编辑

试试这个

Option Explicit

Sub main()

Dim dataRng As Range, dbRng As Range, helperRng As Range, cell As Range, found As Range
Dim rangeArray() As Range
Dim iRng As Long

With Worksheets("MySheet") '<= change it to your actual worksheet name
    Set dbRng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Resize(, 2) '<= change "A1" to your actual data first up-left cell address
    Set dataRng = dbRng.Offset(1).Resize(dbRng.Rows.Count - 1) 'extrapolate data only (headers off)
    'Set helperRng = dbRng.Offset(.UsedRange.Rows.Count + 1, .UsedRange.Columns.Count + 1).Cells(1, 1) ' localize "helper" range out of sheet used range
    Set helperRng = .Range("AA1") ' localize "helper" range from cell "AA1" 
End With
dataRng.Columns(1).SpecialCells(xlCellTypeConstants, xlTextValues).Copy Destination:=helperRng ' copy relevant data into "helper" rang

With helperRng
    If .CurrentRegion.Rows.Count > 1 Then .CurrentRegion.RemoveDuplicates Columns:=Array(1), Header:=xlNo ' take only samples unique values
    With .CurrentRegion
        ReDim rangeArray(1 To .Rows.Count) 'size the array to sample unique values number
        For iRng = 1 To .Rows.Count 'loop through sample unique values
            dbRng.AutoFilter field:=1, Criteria1:=helperRng(iRng, 1) ' filter data accordingly to current sample value
            Set rangeArray(iRng) = dataRng.Columns(2).SpecialCells(xlCellTypeVisible) 'store filtered rows columns 2 ranges
            .AutoFilter
        Next iRng
    End With
'    .ClearContents '<== remove the comment once you're done with the example
End With

' here follows an example of exploiting rangeArray array
' once you're done with it, remove this example and uncomment the ".ClearContents" statement by the end of preceeding "With ... End With" block
For iRng = 1 To UBound(rangeArray)
    rangeArray(iRng).Copy
    helperRng.Offset(iRng - 1, 1).Resize(1, rangeArray(iRng).Count).PasteSpecial xlPasteAll, Transpose:=True
Next iRng

End sub

它可以处理任何不同值的样本

如果在一列中满足Excel条件，请将匹配条件旁边的列的值记录到范围

2 个答案: