Манипулировать данными в 1-мерном массиве и копировать их в 2-мерный массив

У меня есть одномерный массив со значениями ниже, и я хочу превратить массив в двумерный, вырезать «/*» и сохранить его во втором измерении. Результат предполагается посмотреть во второй таблице. Я пытаюсь использовать для этого второй массив, используя следующий код, но по какой-то причине я получаю сообщение о несовместимости типов в строке arr2(i, i) = Mid(arr1(i), 1, arrSffx).

Sub Test2()

    Dim arr1 As Variant
    Dim arr2 As Variant
    Dim i, j, arrSffx, arrLen As Long
      
    arr1 = getUniqueValuesFromRange(Worksheets("table1").UsedRange.Columns("A"))
    
    For i = 0 To UBound(arr1)
    
        arrSffx = InStrRev(arr1(i), "/")
        arrLen = Len(arr1(i))
    
        arr2(i, i) = Mid(arr1(i), 1, arrSffx)
        arr2(i, i + 1) = Mid(arr1(i), arrSffx, arrLen - arrSffx)
                
    Next i
    
    For i = 0 To UBound(arr2)
    
        Worksheets("table1").Range("D" & i + 2) = arr1(i, i)
        Worksheets("table1").Range("D" & i + 2) = arr1(i, i + 1)
    
    Next i
    
End Sub

Где размер arr2? Кроме того, вы упомянули, что arr1 — это 1D, но тогда в вашем коде есть arr1(i, i)? Также i, i выглядит подозрительно.

BigBen 08.12.2022 15:00

Почему вы пишете в одну и ту же ячейку дважды? Worksheets("table1").Range("D" & i + 2) используется дважды?

BigBen 08.12.2022 15:06
Преобразование HTML-таблицы в профессиональный документ Excel
Преобразование HTML-таблицы в профессиональный документ Excel
Это самый простой способ создания Excel из HTML-таблицы.
Импорт excel в laravel в базу данных
Импорт excel в laravel в базу данных
Здравствуйте, дорогой читатель, в этой статье я расскажу практическим и быстрым способом, как импортировать файл Excel в вашу базу данных с помощью...
0
2
82
4
Перейти к ответу Данный вопрос помечен как решенный

Ответы 4

Ответ принят как подходящий

Вы можете использовать эту функцию

Public Function splitArray(arr As Variant, delimiter As String) As Variant
Dim arrReturn As Variant
ReDim arrReturn(UBound(arr), 1)

Dim i As Long, posDelimiter As Long
For i = LBound(arr) To UBound(arr)
    posDelimiter = InStr(arr(i), delimiter)
    arrReturn(i, 0) = Left(arr(i), posDelimiter - 1)
    arrReturn(i, 1) = Mid(arr(i), posDelimiter)
Next
splitArray = arrReturn
End Function

и использовать его так


Sub Test2()

    Dim arr1 As Variant
    Dim arr2 As Variant
      
    arr1 = getUniqueValuesFromRange(Worksheets("table1").UsedRange.Columns("A"))
    arr2 = splitArray(arr1, "/")
    
    Dim rgTarget As Range
    Set rgTarget = Worksheets("table1").Range("D1")
    
    rgTarget.Resize(UBound(arr2, 1), 2).Value = arr2
        
End Sub

Будет проще, если вы позволите встроенным функциям vba и других библиотек (mscorlib) взять на себя нагрузку.

В этом решении используется объект ArrayList, который можно найти в библиотеке mscorlib (добавьте ссылку на mscorlib).

Он также использует метод VBA «Разделить», который можно использовать для разделения строки на несколько подстрок с использованием разделителя. В вашем случае вам нужно добавить разделитель во вторую строку.

Sub Test2()

    Dim myUniqueValues As ArrayList
    Set myUniqueValues = GetUniqueValuesFromRange(Worksheets("table1").UsedRange.Columns("A"))
    
    Dim myOutput As Variant
    ReDim myOutput(1 To myUniqueValues.Count, 1 To 2)
    
    Dim myTmp As Variant
    Dim myIndex As Long
    myIndex = 1
    Dim myItem As Variant
    For Each myItem In myUniqueValues
    
        myTmp = VBA.Split(myItem, "/")
        myOutput(myIndex, 1) = myTmp(0)
        myOutput(myIndex, 2) = "/" & myTmp(1)
        myIndex = myIndex + 1
        
    Next
    
    Worksheets("table1").Range("D1:E" & CStr(myUniqueValues.Count)) = myOutput
    
End Sub

Public Function GetUniqueValuesFromRange(ByVal ipRange As Excel.Range) As ArrayList

    Dim myInputArray As Variant
    myInputArray = ipRange.Value
    
    Dim myAL As ArrayList
    Set myAL = New ArrayList
    
    Dim myItem As Variant
    For Each myItem In myInputArray
        If Not myAL.Contains(myItem) Then
            myAL.Add myItem
        End If
    Next
    
    Set GetUniqueValuesFromRange = myAL
    
End Function

что касается уникальных значений - вам не нужна специальная библиотека - смотрите мой ответ здесь: stackoverflow.com/a/74730267/16578424

Ike 08.12.2022 16:30

Спасибо за ссылку. Я не пользователь Excel, поэтому, очевидно, пропустил этот трюк.

freeflow 08.12.2022 16:36

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

'This function tranforms a 1 dimensional array to a 2 dimensional array
'Arguments:
'  arg_1D = A 1 dimensional array
'   Required
'  arg_sDelimiter = The delimiter to split elements on to create a 2 dimensional array
'   Optional
'   Default value is "/"
'  arg_bIncludeDelim = Boolean (True/False) value on whether to include the delimiter in the output results
'   Optional
'   Default is True
Function Transform_1D_to_2D_Array( _
    ByVal arg_a1D As Variant, _
    Optional ByVal arg_sDelimiter As String = "/", _
    Optional ByVal arg_bIncludeDelim As Boolean = True _
) As Variant
    
    'Verify passed argument is actually a 1 dimensional array
    If Not IsArray(arg_a1D) Then
        Exit Function   'argument is not an array
    Else
        Dim lTestExtraDimension As Long
        On Error Resume Next
        lTestExtraDimension = UBound(arg_a1D, 2) - LBound(arg_a1D, 2) + 1
        On Error GoTo 0
        If lTestExtraDimension > 0 Then
            Exit Function   'argument is an array, but already has more than 1 dimension
        End If
    End If
    
    'Get maximum number of delimiters in the data
    'This allows the resulting 2d array to handle any number of resulting columns
    Dim vElement As Variant
    Dim lNumDelims As Long, lMax As Long
    For Each vElement In arg_a1D
        lNumDelims = ((Len(vElement) - Len(Replace(vElement, arg_sDelimiter, vbNullString))) / Len(arg_sDelimiter)) + 1
        If lNumDelims > lMax Then lMax = lNumDelims
    Next vElement
    
    'Prepare the 2D results array
    Dim a2D() As Variant:   ReDim a2D(1 To (UBound(arg_a1D) - LBound(arg_a1D) + 1), 1 To lMax)
    
    'Prepare loop variables
    Dim aTemp As Variant, vTemp As Variant
    Dim lRowIndex As Long, lColIndex As Long
    
    'Loop through 1D array
    For Each vElement In arg_a1D
        lRowIndex = lRowIndex + 1   'Increase 2D's row index
        lColIndex = 0               'Reset 2D's col index
        
        'Split the current 1D array element by the delimiter
        aTemp = Split(vElement, arg_sDelimiter)
        
        'Loop through the temporary array that has been created by Split
        For Each vTemp In aTemp
            lColIndex = lColIndex + 1   'Advance the ColIndex
            
            'If including the delimiter in the results, and if the column index is > 1, add the delimiter to the result
            If arg_bIncludeDelim And lColIndex > 1 Then a2D(lRowIndex, lColIndex) = arg_sDelimiter
            
            'Output the result to the appropriate row and column in the 2D array
            a2D(lRowIndex, lColIndex) = a2D(lRowIndex, lColIndex) & vTemp
        Next vTemp
    Next vElement
    
    'Return 2 dimensional results array
    Transform_1D_to_2D_Array = a2D
    
End Function

Вот как бы вы это назвали:

Sub tgr()
    
    'Delcare and set worksheet and range variables
    Dim ws As Worksheet:    Set ws = ThisWorkbook.Worksheets("table1")
    Dim rData As Range:     Set rData = ws.UsedRange.Columns("A")
    
    'Call function GetUniqueValuesFromRange and populate the results into an array
    Dim aUnqVals() As Variant:  aUnqVals = GetUniqueValuesFromRange(rData)
    
    'Verify the array has results and that the data range wasn't empty
    If UBound(aUnqVals) - LBound(aUnqVals) + 1 = 0 Then
        MsgBox "ERROR: No data found in " & rData.Address(External:=True)
        Exit Sub
    End If
    
    'Call function Transform_1D_to_2D_Array to convert the 1 dimensional array into a 2 dimensional array
    Dim aTransformed As Variant:    aTransformed = Transform_1D_to_2D_Array(aUnqVals)
    
    'Verify the result is actually an array
    If Not IsArray(aTransformed) Then
        MsgBox "ERROR: Attempted to transform either a non-array, or array is already multi-dimensional"
        Exit Sub
    End If
    
    'Output results
    ws.Range("D2").Resize(UBound(aTransformed, 1), UBound(aTransformed, 2)).Value = aTransformed
    
End Sub

И для тех, кто заинтересован, это мой взгляд на GetUniqueValuesFromRange:

'This function gets unique values from a range
'Arguments:
'  arg_rData = A range object
'   Required
'  arg_bIgnoreCase = Boolean (True/False) value on whether to ignore case for determing a unique value
'   Optional
'   Default value is True (case sensitivity will be ignored); AKA "TEST" and "test" will be treated as the same unique value
'  arg_bIgnoreBlank = Boolean (True/False) value on whether to ignore blanks in the output results
'   Optional
'   Default is True (blanks will be ignored)
Function GetUniqueValuesFromRange( _
    ByVal arg_rData As Range, _
    Optional ByVal arg_bIgnoreCase As Boolean = True, _
    Optional ByVal arg_bIgnoreBlank As Boolean = True _
) As Variant()
    
    'Convert the range of values into an array
    Dim aData() As Variant
    If arg_rData.Cells.Count = 1 Then
        ReDim aData(1 To 1, 1 To 1)
        aData(1, 1) = arg_rData.Value
    Else
        aData = arg_rData.Value
    End If
    
    'Prepare a dictionary object in order to identify unique values
    Dim hUnqVals As Object: Set hUnqVals = CreateObject("Scripting.Dictionary")
    
    'If ignoring case sensitivity, set the compare mode to vbTextCompare
    If arg_bIgnoreCase Then hUnqVals.CompareMode = vbTextCompare
    
    'Loop through the array of values
    Dim vData As Variant
    For Each vData In aData
        'Test if value is blank
        If Len(vData) = 0 Then
            'If ignoring blanks, the skip this value, otherwise include it (if not already included)
            If arg_bIgnoreBlank = False Then
                If hUnqVals.Exists(vData) = False Then hUnqVals.Add vData, vData
            End If
        Else
            'Value not blank, include it (if not already included)
            If hUnqVals.Exists(vData) = False Then hUnqVals.Add vData, vData
        End If
    Next vData
    
    'Return unique values
    GetUniqueValuesFromRange = hUnqVals.Keys
    
End Function

Изображение, показывающее исходные данные и результаты (с примером одной из точек данных, требующей третьего столбца на основе разделителя):

Массивы: 1D в 2D с разделением

Sub OneDToTwoD()

    ' Reference the Source range.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets("Table1")
    Dim srg As Range: Set srg = ws.UsedRange.Columns("A")
      
    ' Using the 'getUniqueValuesFromRange' function,
    ' return the unique values of the Source range in a 1D array.
    Dim Arr As Variant: Arr = getUniqueValuesFromRange(srg)
    
    ' Split the strings in the 1D array and return the substrings
    ' in a 2D one-based two-column array.
    
    Dim rCount As Long: rCount = UBound(Arr) - LBound(Arr) + 1
    Dim Data() As Variant: ReDim Data(1 To rCount, 1 To 2)
    
    Dim i As Long, r As Long, strPos As Long, strLen As Long
    
    For i = LBound(Arr) To UBound(Arr)
        strPos = InStrRev(Arr(i), "/")
        strLen = Len(Arr(i))
        r = r + 1
        Data(r, 1) = Mid(Arr(i), 1, strPos - 1) ' exclude delimiter
        Data(r, 2) = Mid(Arr(i), strPos, strLen - strPos + 1) ' include delim. ?
        'Data(r, 2) = Mid(Arr(i), strPos + 1, strLen - strPos) ' exclude delim.
    Next i
    
    ' Reference the Destination range.
    Dim drg As Range: Set drg = ws.Range("D2").Resize(rCount, 2)
    
    ' Write the values from the 2D array to the Destination range.
    drg.Value = Data
    
End Sub

Если ваша функция не исключает первую строку, вы можете сослаться на исходный диапазон следующим образом:

Dim srg As Range
With ws.UsedRange.Columns("A")
    Set srg = .Resize(.Rows.Count - 1).Offset(1)
End With

Другие вопросы по теме