У меня есть одномерный массив со значениями ниже, и я хочу превратить массив в двумерный, вырезать «/*» и сохранить его во втором измерении. Результат предполагается посмотреть во второй таблице. Я пытаюсь использовать для этого второй массив, используя следующий код, но по какой-то причине я получаю сообщение о несовместимости типов в строке 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
Почему вы пишете в одну и ту же ячейку дважды? Worksheets("table1").Range("D" & i + 2)
используется дважды?
Вы можете использовать эту функцию
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
Спасибо за ссылку. Я не пользователь Excel, поэтому, очевидно, пропустил этот трюк.
Вот сильно прокомментированный код о том, как преобразовать одномерный массив в двумерный массив с помощью разделителя. Преимущество этого метода в том, что результат не ограничен двумя колонками, это может быть любое количество колонок:
'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
Изображение, показывающее исходные данные и результаты (с примером одной из точек данных, требующей третьего столбца на основе разделителя):
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
Где размер
arr2
? Кроме того, вы упомянули, чтоarr1
— это 1D, но тогда в вашем коде естьarr1(i, i)
? Такжеi, i
выглядит подозрительно.