将数组写入单元格

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