Excel-VBA разделяет строку и сохраняет результат в отдельные массивы

Question

У меня есть много строк в формате Topic/Subtopic. Мне нужно отделить их обоих и сохранить результаты темы и подтемы в разные массивы.

Мой код:

Dim strText() As String 
Dim seperate As Variant 

i = QB_StartCell '4 

ReDim strText(1 To 25) 

'collecting all the types in an array 
Do While Worksheets("QB").Cells(i, QB_Thema).Value <> "" 'QB_Thema is a column number 
    strText(i) = Worksheets("QB").Cells(i, QB_Thema).Value 
    MsgBox strText(i) 
    i = i + 1 
Loop 

noThema = i - QB_StartCell 

'splitting all the types into 2 parts 
Do 

seperate = Split(strText(p), "/") 

Loop Until p > noThema 

Теперь я хочу обе расщепленные части в раздельных Массивы, как я хочу получить доступ к ним позже. Любая помощь ?

Answer 1

Нет необходимости повторять итерацию дважды, сначала через ячейки, а затем через массив.

Вы можете сделать это в одной итерации, как это:

Option Explicit 

Sub main() 
Dim i As Long, lastRow As Long, nonBlankCellsNumber As Long 
Dim QB_Thema As Long, QB_StartCell As Long 
Dim cell As Range 
Dim topicArr() As String, subTopicArr() As String 

QB_Thema = 3 'added this for my test 
QB_StartCell = 4 

lastRow = GetLastRow(Worksheets("QB"), QB_Thema, "F", QB_StartCell) '<== I assumed as per your code that you stop at the first occurrence of a blank cell. should you want to process all non blank data to the last non blank cell, then use "L" as the 3rd argument of this call 
If lastRow = -1 Then Exit Sub 

With Worksheets("QB") 
    With .Range(.Cells(QB_StartCell, QB_Thema), .Cells(lastRow, QB_Thema)) 
     nonBlankCellsNumber = WorksheetFunction.CountA(.Cells) 
     ReDim topicArr(1 To nonBlankCellsNumber) 
     ReDim subTopicArr(1 To nonBlankCellsNumber) 
     i = 0 
     For Each cell In .Cells.SpecialCells(xlCellTypeConstants, xlTextValues) 
      i = i + 1 
      topicArr(i) = Split(cell.value, "/")(0) 
      subTopicArr(i) = Split(cell.value, "/")(1) 
     Next cell 
    End With 
End With 

End Sub 


Function GetLastRow(sht As Worksheet, columnIndex As Long, FirstOrLastBlank As String, Optional firstRow As Variant) As Long 
If IsMissing(firstRow) Then firstRow = 1 
With sht 
    If FirstOrLastBlank = "F" Then 
     With .Cells(firstRow, columnIndex) 
      If .value = "" Then 
       GetLastRow = .End(xlDown).End(xlDown).row 
      Else 
       GetLastRow = .End(xlDown).row 
      End If 
     End With 
     If GetLastRow = .Rows.count And .Cells(GetLastRow, columnIndex) = "" Then GetLastRow = firstRow 
    ElseIf FirstOrLastBlank = "F" Then 
     GetLastRow = .Cells(.Rows.count, columnIndex).End(xlUp).row 
     If GetLastRow < firstRow Then GetLastRow = firstRow 
    Else 
     MsgBox "invalid 'FirstOrLastBlank' parameter" 
     GetLastRow = -1 
    End If 
End With 
End Function 

Как вы видите, я также отправил Function GetLastRow(), чтобы получить последний индекс строки данных для сканирования.

В соответствии с вашим кодом, я хочу, чтобы вы начали с строки 4 и остановились в первой пустой ячейке (исключены), и поэтому я настроил аргументы (а именно 3-й: "F") в вызове GetLastRow соответственно.

Вместо этого, если вы хотите отсканировать все непустые ячейки в указанном столбце, вы можете вызвать ту же функцию GetLastRow, передав "L" в качестве третьего параметра.

Answer 2

2 решения: один 2D массив или два 1D массив

Dim arr_Multi(noThema, 2) As String 
Dim arr_Topic(noThema) As String 
Dim arr_SubTopic(noThema) As String 

Do 
    seperate = Split(strText(p), "/") 

    ' Choose either storage in one 2D array 
     arr_Multi(p, 0) = seperate(0) 
     arr_Multi(p, 1) = seperate(1) 

    ' or storage in two 1D arrays 
     arr_Topic(p) = seperate(0) 
     arr_SubTopic(p) = seperate(1) 

    p = p + 1 ' and don't forget to increment your counter in the loop 

Loop Until p > noThema 

---

Если вам нужен массив (ы) вне подлодки, то вы должны объявить их, как это на верхней части модуля:

Dim arr_Multi(1, 2) As String 
Dim arr_Topic(1) As String 
Dim arr_SubTopic(1) As String 

И в цикле вы делаете redim preserve вашего массива (ов) до приращения p:

' Either 
redim preserve arr_Multi(p, 2) 

'or 
redim preserve arr_Topic(p) 
redim preserve arr_SubTopic(p)