Создайте новый массив, который содержит только выбранные строки из предыдущего массива на основе переменной в столбце

Question

Я пытаюсь создать новый массив, который содержит только выбранные значения из предыдущего массива на основе переменной.

Например, у меня есть это в виде массива:

Используя поле выбора из формы пользователя, я хочу быть например, возможность выбрать элемент № 15 (в столбце 1) и получить новый массив только из строк, содержащих элемент № 15 (новый массив будет 3 строки на 9 столбцов).

есть идеи, как это сделать? также позволяя ему быть динамическим c, так как я хочу иметь возможность сделать это для разных наборов данных. Я не уверен, что было бы лучше отсортировать по двум столбцам столбец 1, который является элементом #, и последний столбец, который соответствует тому, на каком листе он находится.

Answer 1

HerLow

Основная идея c о том, что вы можете адаптироваться к вашим потребностям ... ... чтобы ответить на этот вопрос .... Я хочу иметь возможность выбрать элемент № 15, например (в столбце 1) и получить новый массив только строк, содержащих элемент № 15 (новый массив будет 3 строки на 9 столбцов).

Option Explicit
Sub ArrayBasedOnRowSelection()
Dim WsList As Worksheet, WsOut As Worksheet
 Set WsList = ThisWorkbook.Worksheets("List"): Set WsOut = ThisWorkbook.Worksheets("Output")
Dim arrIn() As Variant, arrOut() As Variant
 Let arrIn() = WsList.UsedRange
Dim Cnt As Long, strRws As String
    For Cnt = 2 To WsList.UsedRange.Rows.Count
     If arrIn(Cnt, 1) = "15" Then
      Let strRws = strRws & Cnt & " "
     Else
     End If
    Next Cnt
 Let strRws = Left$(strRws, Len(strRws) - 1)
Dim SptStr() As String: Let SptStr() = Split(strRws, " ", -1, vbBinaryCompare)
Dim RwsT() As String: ReDim RwsT(1 To UBound(SptStr()) + 1, 1 To 1)
    For Cnt = 1 To UBound(SptStr()) + 1
     Let RwsT(Cnt, 1) = SptStr(Cnt - 1)
    Next Cnt
Dim Clms() As Variant: Let Clms() = Evaluate("=Column(A:" & CL(WsList.UsedRange.Columns.Count) & ")")  '     Evaluate("=Column(A:I)")

 Let arrOut() = Application.Index(arrIn(), RwsT(), Clms())

 WsOut.Cells.Clear
 Let WsOut.Range("A2").Resize(UBound(arrOut(), 1), WsList.UsedRange.Columns.Count).Value = arrOut
End Sub


'   http://www.excelfox.com/forum/showthread.php/1902-Function-Code-for-getting-Column-Letter-from-Column-Number?p=8824&viewfull=1#post8824
Public Function CL(ByVal lclm As Long) As String '         http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
    Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

Если вы запустите этот макрос, он вставит массив из 3 строк на столько столбцов, сколько ваш используемый диапазон в листе «Список», на основе выбора 15 из столбца 1.

Файл: ArrayfromRowsBasedOnPreviousArray.xlsm: https://app.box.com/s/h9ipfz2ngskjn1ygitu4zkqr1puuzba1

Объяснение: https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172

Алан

Answer 2

Пожалуйста, попробуйте этот код. Он должен быть установлен в стандартном модуле кода. Отрегулируйте перечисления в верхней части, чтобы показать, где находятся данные (предположительно в A2: I13). Код просит указать элемент для извлечения и распечатает извлеченные данные в области на 5 строк ниже оригинала.

Option Explicit

Enum Nws                        ' worksheet navigation
                                ' modify as required
    NwsFirstDataRow = 2
    ' columns and Array elements:-
    NwsItm = 1                  ' indicate column A
    NwsTab = 9                  ' indicate column I
End Enum


Sub Test_DataSelection()

    Dim Ws As Worksheet
    Dim Rng As Range
    Dim Arr As Variant
    Dim Itm As String

    Set Ws = ThisWorkbook.Worksheets("Sheet1")      ' modify as required
    With Ws
        Set Rng = .Range(.Cells(NwsFirstDataRow, NwsItm), _
                         .Cells(.Rows.Count, NwsTab).End(xlUp))
    End With
    Arr = Rng.Value

    Itm = InputBox("Enter a valid Item number", "Select data", 5)
    Arr = SelectedData(Itm, Arr)

    With Ws                                         ' may specify another sheet here
        Set Rng = .Cells(.Rows.Count, NwsItm).End(xlUp).Offset(5)
        Rng.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
    End With
End Sub

Function SelectedData(ByVal Itm As Variant, _
                      Arr As Variant) As Variant()
    ' Variatus @STO 21 Jan 2020

    Dim Fun() As Variant
    Dim Ub As Long
    Dim i As Long
    Dim R As Long, C As Long

    On Error Resume Next
    Ub = UBound(Arr)
    If Err.Number = 0 Then
        On Error GoTo 0
        Itm = Val(Itm)
        ReDim Fun(1 To UBound(Arr, 2), 1 To Ub)
        For R = 1 To Ub
            If Arr(R, 1) = Itm Then
                i = i + 1
                For C = 1 To UBound(Arr, 2)
                    Fun(C, i) = Arr(R, C)
                Next C
            End If
        Next R
        ReDim Preserve Fun(1 To UBound(Fun), 1 To i)
    End If

    SelectedData = Application.Transpose(Fun)
End Function