抓取來源資料另存在目的不同sheet中

rockrun

各位先進們好

小弟有幾個來源文件(檔名相同sheet內容不同)，還有一個目的文件分成好幾個sheet(各sheet中各有對應來源檔)，並指定輸入要的時間匯入

有個小問題
1.讀取來源檔以陣列讀取完後往下一列繼續不是往下一欄繼續，如果我的陣列類型是欄列都有的話。
2.讀取完要寫入目的檔時會寫入全部sheet(會在A1寫入日期B2寫入時間其餘空白) 而不是只寫入其中一個sheet內

請問各位先進該如何更改

1. '每日報表匯入總日報表'
   
2. 
   
3. Sub Test()
   
4.     Dim sFile, wbThis As Workbook, wbSrc As Workbook
   
5.     Dim lRowIndex As Long, lColIndex As Long, oDic As Object, aTime, sDate
   
6.     Dim sType As String, lShIndex As Long, lTimeIndex As Long
   
7. 
   
8.     Const lBlkWidth As Long = 13
   
9.     Const lBlkHeight As Long = 40
   
10. 
    
11.     sFile = Application.GetOpenFilename(fileFilter:="Excel Files (*.xls),*.xls", Title:="選擇日報表")
    
12.     If StrComp(TypeName(sFile), "Boolean", vbTextCompare) = 0 Then Exit Sub
    
13. 
    
14.     aTime = InputBox("輸入要記錄的時間" & "以逗號分開，不要空格)", , "00:00,08:00,16:00")
    
15.     If aTime = "" Then Exit Sub
    
16.     aTime = Split(aTime, ",")
    
17. 
    
18.     Application.ScreenUpdating = False
    
19.     Set wbThis = ThisWorkbook
    
20.     Set wbSrc = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
    
21.     Set oDic = CreateObject("Scripting.Dictionary")
    
22. 
    
23.     With wbSrc.Sheets(1)
    
24.         sDate = .Range("TitleDate").Value
    
25.         For lRowIndex = .[A8].Row To .UsedRange.Rows.Count Step lBlkHeight
    
26.              For lColIndex = 2 To lBlkWidth
    
27.                 sType = .Cells(lRowIndex, lColIndex).Value
    
28.                     If sType <> "" And Left(sType, 1) <> "@" Then
    
29.                         If Not oDic.exists(sType) Then
    
30.                         Set oDic(sType) = CreateObject("scripting.dictionary")
    
31.                         For Each x In .Cells(lRowIndex, 1).Offset(4).Resize(24)
    
32.                             If x.Value <> "" Then oDic(sType)(x.Text) = x.Offset(, lColIndex - 1).Value
    
33.                         Next
    
34.                     End If
    
35.                 End If
    
36.             Next
    
37.         Next
    
38.     End With
    
39.     wbSrc.Close
    
40.     Application.ScreenUpdating = True
    
41. 
    
42.     With wbThis
    
43.         For lShIndex = 1 To .Sheets.Count
    
44.             With .Sheets(lShIndex)
    
45.                 lRowIndex = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
    
46.                     .Cells(lRowIndex, "A").Value = sDate
    
47.                     .Cells(lRowIndex, "B").Resize(UBound(aTime) + 1) = Application.Transpose(aTime)
    
48.                 For lColIndex = 3 To .[C4].End(xlToRight).Column
    
49.                     If oDic.exists(.Cells(4, lColIndex).Value) Then
    
50.                         For lTimeIndex = 0 To UBound(aTime)
    
51.                             .Cells(lRowIndex, lColIndex).Offset(lTimeIndex).Value = oDic(.Cells(4, lColIndex).Value)(aTime(lTimeIndex))
    
52.                         Next
    
53.                         oDic(.Cells(4, lColIndex).Value).RemoveAll
    
54.                         oDic.Remove .Cells(4, lColIndex).Value
    
55.                     End If
    
56.                 Next
    
57.             End With
    
58.         Next
    
59.     End With
    
60. 
    
61.     MsgBox "目標檔找不到欄位資料: " & vbCrLf & Join(oDic.keys, ", ")
    
62.     'cleanup
    
63.     For Each x In oDic
    
64.         oDic(x).RemoveAll
    
65.         oDic.RemoveAll
    
66.     Next
    
67. End Sub

複製代碼