將數組寫入單元格

Question

該代碼查找某個範圍內第一次和最後一次發生的sting，然後構建一個數組。我的問題是我不知道如何將數組寫入到工作表的逗號分隔格式的單元格。 .Find從範圍的開頭開始搜索，然後從範圍的末尾查找搜索結果。都停在搜索變量的第一次出現。

問題： 1.如何提高對速度的代碼作爲100,000+行範圍內，這將在搜索範圍 2.如何寫創建的數組到工作表中的逗號分隔的字符串。

Public Function FindVehicleOptions() 

Dim LastRow As Long 
Dim vArr As Variant 
Dim FindString As String 
Dim Rng1 As Range 
Dim Rng2 As Range 
Dim CellAddress As String 
Dim Cell As Range 
Dim Search As String 
Dim NumRows As Long 
Dim NumCols As Long 
Dim Key As String 
Dim i As Integer 
Dim j As Integer 
Dim x As Integer 
Dim s As String 
Dim wb1 As Excel.Workbook: Set wb1 = Application.Workbooks("AFS Configuration Ver 2.xlsm") 
Dim ws1 As Worksheet: Set ws1 = Sheets("Configuration") 
Dim Destination As Range 
Dim sDelimString As String 
Dim lCounter As Long 

FindString = Sheets("AFS Report").Range("A3") 

If Trim(FindString) <> "" Then 
    With ws1.Range("B:B") 
     Set Rng1 = .Find(What:=FindString, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _ 
         SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) 
      If Not Rng1 Is Nothing Then 
       Application.Goto Rng1, True 
       Debug.Print Rng1.Address 
      Else 
       Debug.Print "Nothing found" 
      End If 
    End With 
End If 

If Trim(FindString) <> "" Then 
    With ws1.Range("B:B") 
     Set Rng2 = .Find(What:=FindString, After:=.Cells(1), LookIn:=xlValues, LookAt:=xlWhole, _ 
         SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False) 
      If Not Rng2 Is Nothing Then 
       Application.Goto Rng2, True 
       Debug.Print Rng2.Address 
        CellAddress = Rng2.Address 
        Set Cell = Range(CellAddress) 
      Else 
       Debug.Print "Nothing found" 
      End If 
    End With 
End If 

vArr = ws1.Range(Rng1.Address & ":" & Rng2.Offset(0, 5).Address).Value 

Debug.Print "New value of " & Rng1.Address & Rng2.Offset(0, 5).Address 

NumRows = UBound(vArr, 1) - LBound(vArr, 1) + 1 
NumCols = UBound(vArr, 2) - LBound(vArr, 2) + 1 
Set Destination = Range("B3") 
Destination.Resize(UBound(vArr, 2), UBound(vArr, 1)).Value = Application.Transpose(vArr) 

End Function 

Answer 1

這裏是放置一個二維陣列成單細胞在CSV形式的一個典型的例子：

Sub dural() 
Dim vArray(1 To 3, 1 To 5) As Long, K As Long 
Dim rDestination As Range, sTringg As String 
Set rDestination = Range("B9") 

K = 1 
For i = 1 To 3 
    For j = 1 To 5 
     vArray(i, j) = K 
     K = K + 1 
    Next j 
Next i 

sTringg = "" 
For i = LBound(vArray, 1) To UBound(vArray, 1) 
    For j = LBound(vArray, 2) To UBound(vArray, 2) 
     sTringg = sTringg & "," & vArray(i, j) 
    Next j 
Next i 
sTringg = Mid(sTringg, 2, Len(sTringg) - 1) 

rDestination = sTringg 

End Sub