VBA：将特定单元格从文件夹选择器识别的文件复制并粘贴到文件选择器识别的目标文件

Question

我的问题：我想从多个工作簿(调用：商业案例(1(和上升(中复制特定的单元格，在这些工作簿中，我想从两个不同的工作表(名为"摘要"one_answers"商业案例输入表"(中复制数据。我不知道如何写代码来正确地复制和粘贴数据？

我想复制的地方：

文件名："商业案例(x("；

片材："；摘要"；

单元格：

D4  D5  D6  D7  D8  K4  K5  K6  K7  K8  E12 F12 E14 E16 E17 E18 E19 E21 E22 E23 E26 E27 E28 E29 G29 E31 E32 E33 E34 E35 E36 E39 E40 E38

从同一个工作簿(商业案例(X((，但另一张表，我想得到以下内容。

片材："；商业案例输入表"；

单元格：

G6  H6  I6  J6  K6  L6  M6  N6  O6  P6  Q6  G34 H34 I34 J34 K34 L34 M34 N34 O34 P34 Q34 G8  H8  I8  J8  K8  L8  M8  N8  O8  P8  Q8  G36 H36 I36 J36 K36 L36 M36 N36 O36 P36 Q36 G35 H35 I35 J35 K35 L35 M35 N35 O35 P35 Q35 G43 H43 I43 J43 K43 L43 M43 N43O43 P43 Q43 G45 H45 I45 J45 K45 L45 M45 N45 O45 P45 Q45 G46 H46 I46 J46 K46 L46 M46 N46 O46 P46 Q46 G47 H47 I47 J47 K47 L47 M47 N47 O47 P47 Q47 G48 H48 I48 J48 K48 L48 M48 N48 O48 P48 Q48 G61 H61 I61 J61 K61 L61 M61 N61 O61 P61 Q61 G62 H62 I62 J62 K62 L62 M62 N62 O62 P62 Q62 G63 H63 I63 J63 K63 L63 M63 N63 O63 P63 Q63 G66 H66 I66 J66 K66 L66 M66 N66 O66 P66 Q66 G68 H68 I68 J68 K68 L68 M68 N68 O68 P68 Q68 G69 H69 I69 J69 K69 L69 M69 N69 O69 P69 Q69 

并且接收文件被命名为："；投资组合概述"；

片材："；数据输入商业案例1的单元格：H41:HK41

商业案例1的单元格：H42:HK42

商业案例1的单元格：H43:HK43

示例

E.g. Data from Qorkbook: Business case 1
Sheet: Summary
Cell: D4 
Copy to
Workbook: Portfolio Tool
Sheet: Datainput
Cell:41
D5 to I41 
D6 to J41 
D7 to K41 
D8 to L41 
K4 to M41 
K5 to N41 
Etc.

依此类推，目标文件中的一行，用于从中检索数据的每个业务案例。

如前所述；我不知道如何编写跨多个工作簿和2张工作表的复制/粘贴代码，以将数据检索到目标文件。

我当前的代码如下：

Option Explicit 'Spell checker
'The "folder picker" macro
Function ChooseFolder(strTitle As String, fDtype) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(fDtype)
With fldr
.Title = strTitle
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
ChooseFolder = sItem
Set fldr = Nothing

End Function
Sub datatransfer_Summary()
'Cancel diasbled, as we dont want half-data etc.
Application.EnableCancelKey = xlDisabled
'Speed optimization
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

'Copy and paste - Thanks to FaneDuru from StackOverflow
Dim FolderPath As String, FilePath As String, Filename As String, iRow As Long
Dim wb1 As Workbook, wb2 As Workbook, shTF As Worksheet

FolderPath = ChooseFolder("Please select the Folder path", msoFileDialogFolderPicker)

FilePath = FolderPath & "Business Case (*.xls*"
Set wb2 = ThisWorkbook
Set shTF = wb2.Worksheets("Datainput")
Filename = Dir(FilePath)
iRow = 41 'starting row to be filled

Do While Filename <> ""
Set wb1 = Workbooks.Open(FolderPath & "" & Filename)
With wb1.Worksheets(1)
shTF.Range("D" & iRow) = wb1.Name
shTF.Range(shTF.Cells(iRow, "H"), shTF.Cells(iRow, "L")).Value = Application.Transpose(.Range("D4:D8").Value)
shTF.Range(shTF.Cells(iRow, "M"), shTF.Cells(iRow, "Q")).Value = Application.Transpose(.Range("K4:K8").Value)
shTF.Range(shTF.Cells(iRow, "R"), shTF.Cells(iRow, "S")).Value = .Range("E12:F12").Value
shTF.Range("T" & iRow).Value = .Range("E14").Value
shTF.Range(shTF.Cells(iRow, "U"), shTF.Cells(iRow, "X")).Value = Application.Transpose(.Range("E16:E19").Value)
shTF.Range(shTF.Cells(iRow, "Y"), shTF.Cells(iRow, "AA")).Value = Application.Transpose(.Range("E21:E23").Value)
shTF.Range(shTF.Cells(iRow, "AB"), shTF.Cells(iRow, "AE")).Value = Application.Transpose(.Range("E26:E29").Value)
shTF.Range("AF" & iRow).Value = .Range("G29").Value
shTF.Range(shTF.Cells(iRow, "AG"), shTF.Cells(iRow, "AL")).Value = Application.Transpose(.Range("E31:E36").Value)
shTF.Range(shTF.Cells(iRow, "AM"), shTF.Cells(iRow, "AN")).Value = Application.Transpose(.Range("E39:E40").Value)
shTF.Range("AO" & iRow).Value = .Range("E38").Value
iRow = iRow + 1
End With

wb1.Close False
Filename = Dir
Loop
'wb2.Close True 'un comment if you want the target workbook to be closed



MsgBox "Finished gathering data"
End Sub
Sub datatransfer_Input_sheet()
'Cancel diasbled, as we dont want half-data etc.
Application.EnableCancelKey = xlDisabled
'Speed optimization
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

'Copy and paste - Thanks to FaneDuru from StackOverflow
Dim FolderPath As String, FilePath As String, Filename As String, iRow As Long
Dim wb1 As Workbook, wb2 As Workbook, shTF As Worksheet

FolderPath = ChooseFolder("Please select the Folder path", msoFileDialogFolderPicker)

FilePath = FolderPath & "Business Case (*.xls*"
Set wb2 = ThisWorkbook
Set shTF = wb2.Worksheets("Datainput")
Filename = Dir(FilePath)
iRow = 41 'starting row to be filled

Do While Filename <> ""
Set wb1 = Workbooks.Open(FolderPath & "" & Filename)
With wb1.Worksheets("Business Case Input sheet")
shTF.Range("AP" & iRow).Value = .Range("G6").Value
shTF.Range("AQ" & iRow).Value = .Range("H6").Value
shTF.Range("AR" & iRow).Value = .Range("I6").Value
shTF.Range("AS" & iRow).Value = .Range("J6").Value
shTF.Range("AT" & iRow).Value = .Range("K6").Value
shTF.Range("AU" & iRow).Value = .Range("L6").Value
shTF.Range("AV" & iRow).Value = .Range("M6").Value
shTF.Range("AW" & iRow).Value = .Range("N6").Value
shTF.Range("AX" & iRow).Value = .Range("O6").Value
shTF.Range("AY" & iRow).Value = .Range("P6").Value
shTF.Range("AZ" & iRow).Value = .Range("Q6").Value
shTF.Range("AZ" & iRow).Value = .Range("Q6").Value
shTF.Range("BA" & iRow).Value = .Range("G34").Value
shTF.Range("BB" & iRow).Value = .Range("H34").Value
shTF.Range("BC" & iRow).Value = .Range("I34").Value
shTF.Range("BD" & iRow).Value = .Range("J34").Value
shTF.Range("BE" & iRow).Value = .Range("K34").Value
shTF.Range("BF" & iRow).Value = .Range("L34").Value
shTF.Range("BG" & iRow).Value = .Range("M34").Value
shTF.Range("BH" & iRow).Value = .Range("N34").Value
shTF.Range("BI" & iRow).Value = .Range("O34").Value
shTF.Range("BJ" & iRow).Value = .Range("P34").Value
shTF.Range("BK" & iRow).Value = .Range("Q34").Value
shTF.Range("BL" & iRow).Value = .Range("G8").Value
shTF.Range("BM" & iRow).Value = .Range("H8").Value
shTF.Range("BN" & iRow).Value = .Range("I8").Value
shTF.Range("BO" & iRow).Value = .Range("J8").Value
shTF.Range("BP" & iRow).Value = .Range("K8").Value
shTF.Range("BQ" & iRow).Value = .Range("L8").Value
shTF.Range("BR" & iRow).Value = .Range("M8").Value
shTF.Range("BS" & iRow).Value = .Range("N8").Value
shTF.Range("BT" & iRow).Value = .Range("O8").Value
shTF.Range("BU" & iRow).Value = .Range("P8").Value
shTF.Range("BV" & iRow).Value = .Range("Q8").Value
shTF.Range("BW" & iRow).Value = .Range("G36").Value
shTF.Range("BX" & iRow).Value = .Range("H36").Value
shTF.Range("BY" & iRow).Value = .Range("I36").Value
shTF.Range("BZ" & iRow).Value = .Range("J36").Value
shTF.Range("CA" & iRow).Value = .Range("K36").Value
shTF.Range("CB" & iRow).Value = .Range("L36").Value
shTF.Range("CC" & iRow).Value = .Range("M36").Value
shTF.Range("CD" & iRow).Value = .Range("N36").Value
shTF.Range("CE" & iRow).Value = .Range("O36").Value
shTF.Range("CF" & iRow).Value = .Range("P36").Value
shTF.Range("CG" & iRow).Value = .Range("Q36").Value
shTF.Range("CH" & iRow).Value = .Range("G35").Value
shTF.Range("CI" & iRow).Value = .Range("H35").Value
shTF.Range("CJ" & iRow).Value = .Range("I35").Value
shTF.Range("CK" & iRow).Value = .Range("J35").Value
shTF.Range("CL" & iRow).Value = .Range("K35").Value
shTF.Range("CM" & iRow).Value = .Range("L35").Value
shTF.Range("CN" & iRow).Value = .Range("M35").Value
shTF.Range("CO" & iRow).Value = .Range("N35").Value
shTF.Range("CP" & iRow).Value = .Range("O35").Value
shTF.Range("CQ" & iRow).Value = .Range("P35").Value
shTF.Range("CR" & iRow).Value = .Range("Q35").Value
shTF.Range("CS" & iRow).Value = .Range("G43").Value
shTF.Range("CT" & iRow).Value = .Range("H43").Value
shTF.Range("CU" & iRow).Value = .Range("I43").Value
shTF.Range("CV" & iRow).Value = .Range("J43").Value
shTF.Range("CW" & iRow).Value = .Range("K43").Value
shTF.Range("CX" & iRow).Value = .Range("L43").Value
shTF.Range("CY" & iRow).Value = .Range("M43").Value
shTF.Range("CZ" & iRow).Value = .Range("N43").Value
shTF.Range("DA" & iRow).Value = .Range("O43").Value
shTF.Range("DB" & iRow).Value = .Range("P43").Value
shTF.Range("DC" & iRow).Value = .Range("Q43").Value
shTF.Range("DD" & iRow).Value = .Range("G45").Value
shTF.Range("DE" & iRow).Value = .Range("H45").Value
shTF.Range("DF" & iRow).Value = .Range("I45").Value
shTF.Range("DG" & iRow).Value = .Range("J45").Value
shTF.Range("DH" & iRow).Value = .Range("K45").Value
shTF.Range("DI" & iRow).Value = .Range("L45").Value
shTF.Range("DJ" & iRow).Value = .Range("M45").Value
shTF.Range("DK" & iRow).Value = .Range("N45").Value
shTF.Range("DL" & iRow).Value = .Range("O45").Value
shTF.Range("DM" & iRow).Value = .Range("P45").Value
shTF.Range("DN" & iRow).Value = .Range("Q45").Value
shTF.Range("DO" & iRow).Value = .Range("G46").Value
shTF.Range("DP" & iRow).Value = .Range("H46").Value
shTF.Range("DQ" & iRow).Value = .Range("I46").Value
shTF.Range("DR" & iRow).Value = .Range("J46").Value
shTF.Range("DS" & iRow).Value = .Range("K46").Value
shTF.Range("DT" & iRow).Value = .Range("L46").Value
shTF.Range("DU" & iRow).Value = .Range("M46").Value
shTF.Range("DB" & iRow).Value = .Range("N46").Value
shTF.Range("DW" & iRow).Value = .Range("O46").Value
shTF.Range("DX" & iRow).Value = .Range("P46").Value
shTF.Range("DY" & iRow).Value = .Range("Q46").Value
shTF.Range("DZ" & iRow).Value = .Range("G47").Value
shTF.Range("EA" & iRow).Value = .Range("H47").Value
shTF.Range("EB" & iRow).Value = .Range("I47").Value
shTF.Range("EC" & iRow).Value = .Range("J47").Value
shTF.Range("ED" & iRow).Value = .Range("K47").Value
shTF.Range("EE" & iRow).Value = .Range("L47").Value
shTF.Range("EF" & iRow).Value = .Range("M47").Value
shTF.Range("EG" & iRow).Value = .Range("N47").Value
shTF.Range("EH" & iRow).Value = .Range("O47").Value
shTF.Range("EI" & iRow).Value = .Range("P47").Value
shTF.Range("EJ" & iRow).Value = .Range("Q47").Value
shTF.Range("EK" & iRow).Value = .Range("G48").Value
shTF.Range("EL" & iRow).Value = .Range("H48").Value
shTF.Range("EM" & iRow).Value = .Range("I48").Value
shTF.Range("EN" & iRow).Value = .Range("J48").Value
shTF.Range("EO" & iRow).Value = .Range("K48").Value
shTF.Range("EP" & iRow).Value = .Range("L48").Value
shTF.Range("EQ" & iRow).Value = .Range("M48").Value
shTF.Range("ER" & iRow).Value = .Range("N48").Value
shTF.Range("ES" & iRow).Value = .Range("O48").Value
shTF.Range("ET" & iRow).Value = .Range("P48").Value
shTF.Range("EU" & iRow).Value = .Range("Q48").Value
shTF.Range("EV" & iRow).Value = .Range("G61").Value
shTF.Range("EW" & iRow).Value = .Range("H61").Value
shTF.Range("EX" & iRow).Value = .Range("H61").Value
shTF.Range("EY" & iRow).Value = .Range("J61").Value
shTF.Range("EZ" & iRow).Value = .Range("K61").Value
shTF.Range("FA" & iRow).Value = .Range("L61").Value
shTF.Range("FB" & iRow).Value = .Range("M61").Value
shTF.Range("FC" & iRow).Value = .Range("N61").Value
shTF.Range("FD" & iRow).Value = .Range("O61").Value
shTF.Range("FE" & iRow).Value = .Range("P61").Value
shTF.Range("FF" & iRow).Value = .Range("Q61").Value
shTF.Range("FG" & iRow).Value = .Range("G62").Value
shTF.Range("FH" & iRow).Value = .Range("H62").Value
shTF.Range("FI" & iRow).Value = .Range("I62").Value
shTF.Range("FJ" & iRow).Value = .Range("J62").Value
shTF.Range("FK" & iRow).Value = .Range("K62").Value
shTF.Range("FL" & iRow).Value = .Range("L62").Value
shTF.Range("FM" & iRow).Value = .Range("M62").Value
shTF.Range("FN" & iRow).Value = .Range("N62").Value
shTF.Range("FO" & iRow).Value = .Range("O62").Value
shTF.Range("FP" & iRow).Value = .Range("P62").Value
shTF.Range("FQ" & iRow).Value = .Range("Q62").Value
shTF.Range("FR" & iRow).Value = .Range("G63").Value
shTF.Range("FS" & iRow).Value = .Range("H63").Value
shTF.Range("FT" & iRow).Value = .Range("I63").Value
shTF.Range("FU" & iRow).Value = .Range("J63").Value
shTF.Range("FV" & iRow).Value = .Range("K63").Value
shTF.Range("FW" & iRow).Value = .Range("L63").Value
shTF.Range("FX" & iRow).Value = .Range("M63").Value
shTF.Range("FY" & iRow).Value = .Range("N63").Value
shTF.Range("FZ" & iRow).Value = .Range("O63").Value
shTF.Range("GA" & iRow).Value = .Range("P63").Value
shTF.Range("GB" & iRow).Value = .Range("Q63").Value
shTF.Range("GC" & iRow).Value = .Range("G66").Value
shTF.Range("GD" & iRow).Value = .Range("H66").Value
shTF.Range("GE" & iRow).Value = .Range("I66").Value
shTF.Range("GF" & iRow).Value = .Range("J66").Value
shTF.Range("GG" & iRow).Value = .Range("K66").Value
shTF.Range("GH" & iRow).Value = .Range("L66").Value
shTF.Range("GI" & iRow).Value = .Range("M66").Value
shTF.Range("GJ" & iRow).Value = .Range("N66").Value
shTF.Range("GK" & iRow).Value = .Range("O66").Value
shTF.Range("GL" & iRow).Value = .Range("P66").Value
shTF.Range("GM" & iRow).Value = .Range("Q66").Value
shTF.Range("GN" & iRow).Value = .Range("G68").Value
shTF.Range("GO" & iRow).Value = .Range("H68").Value
shTF.Range("GP" & iRow).Value = .Range("I68").Value
shTF.Range("GQ" & iRow).Value = .Range("J68").Value
shTF.Range("GR" & iRow).Value = .Range("K68").Value
shTF.Range("GS" & iRow).Value = .Range("L68").Value
shTF.Range("GT" & iRow).Value = .Range("M68").Value
shTF.Range("GU" & iRow).Value = .Range("N68").Value
shTF.Range("GV" & iRow).Value = .Range("O68").Value
shTF.Range("GW" & iRow).Value = .Range("P68").Value
shTF.Range("GX" & iRow).Value = .Range("Q68").Value
shTF.Range("GY" & iRow).Value = .Range("G69").Value
shTF.Range("GZ" & iRow).Value = .Range("H69").Value
shTF.Range("HA" & iRow).Value = .Range("I69").Value
shTF.Range("HB" & iRow).Value = .Range("J69").Value
shTF.Range("HC" & iRow).Value = .Range("K69").Value
shTF.Range("HD" & iRow).Value = .Range("L69").Value
shTF.Range("HE" & iRow).Value = .Range("M69").Value
shTF.Range("HF" & iRow).Value = .Range("N69").Value
shTF.Range("HG" & iRow).Value = .Range("O69").Value
shTF.Range("HH" & iRow).Value = .Range("P69").Value
shTF.Range("HI" & iRow).Value = .Range("Q69").Value


iRow = iRow + 1
End With
wb1.Close False
Filename = Dir
Loop
'wb2.Close True 'un comment if you want the target workbook to be closed

MsgBox "Finished gathering data"
End Sub

最佳Michael

Answer 1

请尝试下一个代码。它将只填充第一部分(直到AO包括在内(。这样做是为了向你展示要遵循的方法。该代码假定目标工作簿是保存VBA代码的工作簿。我只想相信我正确地理解了你真正想要的东西：

Sub datatransfer()
Dim FolderPath As String, FilePath As String, Filename As String, iRow As Long
Dim wb1 As Workbook, wb2 As Workbook, shTF As Worksheet

FolderPath = ChooseFolder("Please select the Folder path", msoFileDialogFolderPicker)

FilePath = FolderPath & "Business Case (*.xls*" 
Set wb2 = ThisWorkbook
Set shTF = wb2.Worksheets("Datainput")
Filename = Dir(FilePath)
iRow = 41 'starting row to be filled

Do While Filename <> ""
Set wb1 = Workbooks.Open(FolderPath & "" & Filename)
With wb1.Worksheets(1)
shTF.Range("D" & iRow) = wb1.Name
shTF.Range(shTF.Cells(iRow, "H"), shTF.Cells(iRow, "L")).Value = Application.Transpose(.Range("D4:D8").Value)
shTF.Range(shTF.Cells(iRow, "M"), shTF.Cells(iRow, "Q")).Value = Application.Transpose(.Range("K4:K8").Value)
shTF.Range(shTF.Cells(iRow, "R"), shTF.Cells(iRow, "S")).Value = .Range("E12:F12").Value
shTF.Range("T" & iRow).Value = .Range("E14").Value
shTF.Range(shTF.Cells(iRow, "U"), shTF.Cells(iRow, "X")).Value = Application.Transpose(.Range("E16:E19").Value)
shTF.Range(shTF.Cells(iRow, "Y"), shTF.Cells(iRow, "AC")).Value = Application.Transpose(.Range("E21:E27").Value)
shTF.Range("AD" & iRow).Value = .Range("E27").Value
shTF.Range("AE" & iRow).Value = .Range("E29").Value
shTF.Range("AF" & iRow).Value = .Range("G29").Value
shTF.Range(shTF.Cells(iRow, "AG"), shTF.Cells(iRow, "AL")).Value = Application.Transpose(.Range("E32:E36").Value)
shTF.Range(shTF.Cells(iRow, "AM"), shTF.Cells(iRow, "AN")).Value = Application.Transpose(.Range("E39:E40").Value)
shTF.Range("AO" & iRow).Value = .Range("E38").Value
iRow = iRow + 1
End With
wb1.Close False
Filename = Dir
Loop
'wb2.Close True 'un comment if you want the target workbook to be closed
End Sub

请使用相同的功能设置保存要处理的工作簿的文件夹。

我想在测试后收到一些反馈。还有澄清问题，如果有些地方不够清楚。。。但现在应该是学习和自己动手的正确时机。如果你不能处理，我仍然会帮助你，但只是提供一些建议。否则，如果只使用你无法理解的代码，你将永远不会学习编码！

编辑：

请使用数组测试(并学习(下一种方法。您可以在不更改代码的情况下更改要返回的值的范围。。。

Sub DataTransferArrayVariant()
Dim FolderPath As String, FilePath As String, Filename As String, iRow As Long
Dim wb1 As Workbook, wb2 As Workbook, shTF As Worksheet

FolderPath = ChooseFolder("Please select the Folder path", msoFileDialogFolderPicker)

FilePath = FolderPath & "Business Case (*.xls*" 'you wrongly copied this line...
Set wb2 = ThisWorkbook
Set shTF = wb2.Worksheets("Datainput")
Filename = Dir(FilePath)
iRow = 41 'starting row to be filled

'The new arrays approach:_________________________________________________________________________
Dim arrAddr1, arrAddr2, arrFin1, arrFin2, k1 As Long, k2 As Long, i As Long
'let us say that the information regarding the cells where from the value to be taken will be in the range "G33:AO33"
'first cell keeps the sheet name
'the second range will be "AQ33:HK33". The same about the first cell (the sheet  name)
arrAddr1 = shTF.Range("G33:AO33")     'change here the row according to your case
arrAddr2 = shTF.Range("AQ33:HK33")   'change here the row according to your case
ReDim arrFin1(1 To 30, 1 To UBound(arrAddr1, 2) + 4) 'redim first array to collect the processing values (from first sheet)
ReDim arrFin2(1 To 30, 1 To UBound(arrAddr2, 2) + 1) 'redim second array to collect the processing values (from second sheet)

k = 1  'initialize the first row of arrays
Do While Filename <> ""
Set wb1 = Workbooks.Open(FolderPath & "" & Filename)
'process the first sheet necessary ranges:_ _ _ _ _ _ _ _ _
With wb1.Worksheets(arrAddr1(1, 1))
arrFin1(k, 1) = wb1.Name         'workbook name
arrFin1(k, 4) = arrAddr1(1, 1)    'worksheet name
For i = 2 To UBound(arrAddr1, 2)
arrFin1(k, i + 3) = .Range(arrAddr1(1, i)) 'put in the array each necessary values from the necessary ranges
Next i
End With
'_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
'process the second sheet necessary ranges:__ __ __ __ __
With wb1.Worksheets(arrAddr2(1, 1))
arrFin1(k, 1) = arrAddr2(1, 1)    'worksheet name
For i = 2 To UBound(arrAddr2, 2)
arrFin2(k, i) = .Range(arrAddr2(1, i))  'put in the array each necessary values from the necessary ranges
Next i
End With
'__ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __ __
k = k + 1 'increment the array row

wb1.Close False   'close the input workbook
Filename = Dir    'determine the next workbook to be open
Loop
'______________________________________________________________________________________________
'Drop the arrays content in the appropriate cells (column D:D and AQ:AQ):
shTF.Range("D" & iRow).Resize(UBound(arrFin1), UBound(arrFin1, 2)).Value = arrFin1
shTF.Range("AQ" & iRow).Resize(UBound(arrFin2), UBound(arrFin2, 2)).Value = arrFin2
End Sub

假设：

应返回值的单元格地址的定义必须存在于目标工作簿工作表("数据输入"(的一行中。上面的代码使用第33行。如果您将使用另一个，请调整范围("G33:AO33"one_answers"AQ33:HK33"(。这些范围的第一列中包含将从中提取数据的工作表名称。

请测试它，试着理解它的含义(我评论了所有的行(并发送一些反馈。如果有什么事情不够清楚，请毫不犹豫地询问！