Inhalt aus Array zurückschreiben - aber wie?

Public Sub CPU_Import()
Dim objFileSearch As clsFileSearch
Dim lngIndex As Long
Dim strSuwort As String
Dim i As Integer
Dim bolErg As Boolean
Dim Zelle_C As Long
Dim Zelle_R As Long
Dim Wert As Long
Dim iZeile As Long, tempZeile As Long, iZähler As Long
Dim WS1 As Worksheet, WS2 As Worksheet
Dim strOrdner As String
Dim arr(1, 8)
Dim Zeile1 As Long
'Vorhandene Daten im Ziel löschen
'ActiveWorkbook.Worksheets("ISR Import Database").AutoFilter.Sort.SortFields. _
Clear
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
If Range("A3")  "" Then
'Range("A3", ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete
'Range("A3").Select
Range("A3").End(xlDown).Offset(1, 0).Select
Else
Range("A3").Select
End If
Set objFileSearch = New clsFileSearch
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "C:\"
.InitialFileName = Environ("Userprofile") & "\Documents\"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1)  "\" Then strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
If strOrdner = "" Then MsgBox ("Kein Ordner gewählt!") 'Else MsgBox strOrdner
'strSuwort = InputBox("Suchwort eingeben")
strSuwort = "Pos"
With objFileSearch
.CaseSenstiv = False
.Extension = "*.xls*"
'.FolderPath = "D:\temp\"
.FolderPath = strOrdner
.SearchLike = "*"
.SubFolders = False
'.SubFolders = True
If .Execute(Sort_by_Size, Sort_Order_Descending) > 0 Then
Application.ScreenUpdating = False
For lngIndex = 1 To .FileCount
With .Files(lngIndex)
Workbooks.Open (.strPath)                         'Workbook öffnen
On Error Resume Next
For i = 1 To Workbooks(.strFilename).Worksheets.Count
With Workbooks(.strFilename).Worksheets(i)
.Activate
bolErg = .Cells.Find(What:=strSuwort, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,  _
MatchCase:=False).Activate
If bolErg Then
'Ermittlung relevanter Einträge
Set WS1 = Application.ActiveSheet
Set WS2 = Application.Workbooks("SQ_BSC-Overview__FY18.xlsm").Worksheets("CPU-Import database")
Zelle_C = ActiveCell.Column
Zelle_R = ActiveCell.Row
arr(1, 1) = WS1.Cells(1, 14)
arr(1, 4) = ActiveWorkbook.Name
If WS1.Name  "Zusammenfassung" And _
WS1.Cells(Zelle_R, Zelle_C + 1) = "Motor" Then
tempZeile = WS2.Cells(WS2.Rows.Count, 1).End(xlUp).Row
Zeile1 = tempZeile + 1
For iZeile = WS1.Cells(WS1.Rows.Count, Zelle_C).End(xlUp).Row To Zelle_R + 1 Step -1
If IsNumeric(WS1.Cells(iZeile, Zelle_C)) Then
If WS1.Cells(iZeile, 2)  "" And _
WS1.Cells(iZeile, 3)  "" Then
If Left(WS1.Cells(iZeile, 3), 4)  "Prob" And _
Left(WS1.Cells(iZeile, 3), 4)  "Besc" Then
iZähler = iZähler + 1
'--- Werte ins Array
tempZeile = tempZeile + 1
'tempZeile = WS2.Cells(WS2.Rows.Count, 1).End(xlUp).Row + 1
'WS2.Rows(tempZeile).Insert Shift:=xlDown
'WS2.Cells(tempZeile, 1) = WS1.Cells(1, 14)
'WS2.Cells(tempZeile, 2) = WS1.Cells(iZeile, 1)
'WS2.Cells(tempZeile, 3) = WS1.Cells(iZeile, 2)
arr(1, 2) = WS1.Cells(iZeile, 1)
arr(1, 3) = WS1.Cells(iZeile, 2)
'WS2.Cells(tempZeile, 4) = ActiveWorkbook.Name
'WS2.Cells(tempZeile, 5) = WS1.Cells(iZeile, 3)
arr(1, 5) = WS1.Cells(iZeile, 3)
Wert = WS1.Cells(iZeile, Zelle_C + 9)
If Wert > 0 Then
'WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 9)
arr(1, 6) = WS1.Cells(iZeile, Zelle_C + 9)
'WS2.Cells(tempZeile, 7) = "MOS"
arr(1, 7) = "MOS"
Wert = 0
End If
Wert = WS1.Cells(iZeile, Zelle_C + 10)
If Wert > 0 Then
'WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 10)
arr(1, 6) = WS1.Cells(iZeile, Zelle_C + 10)
'WS2.Cells(tempZeile, 7) = "ZVM"
arr(1, 7) = "ZVM"
Wert = 0
End If
Wert = WS1.Cells(iZeile, Zelle_C + 11)
If Wert > 0 Then
'WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 11)
arr(1, 6) = WS1.Cells(iZeile, Zelle_C + 11)
'WS2.Cells(tempZeile, 7) = "FT"
arr(1, 7) = "FT"
Wert = 0
End If
Wert = WS1.Cells(iZeile, Zelle_C + 12)
If Wert > 0 Then
'WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 12)
arr(1, 6) = WS1.Cells(iZeile, Zelle_C + 12)
'WS2.Cells(tempZeile, 7) = "SQ"
arr(1, 7) = "SQ"
Wert = 0
End If
Wert = WS1.Cells(iZeile, Zelle_C + 13)
If Wert > 0 Then
'WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 13)
arr(1, 6) = WS1.Cells(iZeile, Zelle_C + 13)
'WS2.Cells(tempZeile, 7) = "WHM"
arr(1, 7) = "WHM"
Wert = 0
End If
Wert = WS1.Cells(iZeile, Zelle_C + 14)
If Wert > 0 Then
'WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile,  _
Zelle_C + 14)
arr(1, 6) = WS1.Cells(iZeile, Zelle_C + 14)
'WS2.Cells(tempZeile, 7) = "R&D"
arr(1, 7) = "R&D"
Wert = 0
End If
Wert = WS1.Cells(iZeile, Zelle_C + 15)
If Wert > 0 Then
'WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile,  _
Zelle_C + 15)
arr(1, 6) = WS1.Cells(iZeile, Zelle_C + 15)
'WS2.Cells(tempZeile, 7) = "Unklar"
arr(1, 7) = "Unklar"
Wert = 0
End If
'WS2.Cells(tempZeile, 8) = getZahl(WS1.Cells(iZeile, 3))
arr(1, 8) = getZahl(WS1.Cells(iZeile, 3))
'WS2.Cells(tempZeile, 9).FormulaArray = _
"=INDEX('PPM Import Database'!R5C1:R150000C14,MATCH(RC[-1]&"""",'PPM Import  _
Database'!R5C4:R150000C4,0),14)"
'WS2.Cells(tempZeile, 10).FormulaArray = _
"=INDEX('PPM Import Database'!R5C1:R150000C14,MATCH(RC[-2]&"""",'PPM Import  _
Database'!R5C4:R150000C4,0),6)"
'WS2.Cells(tempZeile, 11).FormulaArray = _
"=INDEX('ZZQME_PARTNER'!C[-10]:C[-7],MATCH(RC[-1],'ZZQME_PARTNER'!C[-10],0),4)"
End If
End If
End If
'--- Array in Zellbereich schreiben
WS2.Cells(tempZeile, 4).Resize(, 8) = arr
Next iZeile
'--- Formeln einfügen
WS2.Cells(Zeile1, 9).FormulaArray = _
"=INDEX('PPM Import Database'!R5C1:R150000C14,MATCH(RC[-1]&"""",'PPM Import  _
Database'!R5C4:R150000C4,0),14)"
WS2.Cells(Zeile1, 10).FormulaArray = _
"=INDEX('PPM Import Database'!R5C1:R150000C14,MATCH(RC[-2]&"""",'PPM Import  _
Database'!R5C4:R150000C4,0),6)"
WS2.Cells(Zeile1, 11).FormulaArray = _
"=INDEX('ZZQME_PARTNER'!C[-10]:C[-7],MATCH(RC[-1],'ZZQME_PARTNER'!C[-10],0),4)"
WS2.Cells(Zeile1, 9).Resize(1, 2).Copy WS2.Cells(Zeile1, 9).Resize(tempZeile - _
Zeile1 + 1)
End If
'MsgBox "Import erfolgreich!"
Else
'MsgBox "Suchwort nicht gefunden"
bolErg = False
End If
End With
Next i
Workbooks(.strFilename).Close savechanges:=False   'Workbook schließen
End With
Next
Else
'MsgBox "Keine Datei gefunden"
End If
Application.ScreenUpdating = True
End With
Set objFileSearch = Nothing
End Sub