[發問] 請問來源資料自動判定時間輸入相應的sheet內

rockrun

各位前輩及大大們好
小弟有個問題

有兩個來源檔資料要匯入相應的工作表中

下載 (255.47 KB)
圖2

2013-12-4 22:15

下載 (218.82 KB)
圖3

2013-12-4 22:15

來源檔的中的1、2和B2~M2、B38~M38、B74~M74.....抬頭名稱和目的檔3的B4~BT4抬頭名稱相同但"工作表"不同

目的檔的時間點要抓取來源檔的N2後匯入需要的時間點，由於來源檔每次檔名會不同但格式相同

來源檔匯入目的檔所需資料後下次資料匯入會從下一列以同樣的方法作業

下載 (133.01 KB)
圖1

2013-12-4 22:15

Daily Report.rar (445.97 KB)

下載次數: 3

2013-12-4 22:09

stillfish00

回復 1# rockrun
抬頭名稱和目的檔不同呢，像B38 或 B74 ....

rockrun

回復 2# stillfish00


    抱歉抱歉 小弟眼挫  每月keyin那麼久卻沒發現 :dizzy:

Daily Report.rar (446.64 KB)

下載次數: 8

2013-12-4 23:33

stillfish00

回復 3# rockrun

1. Sub Test()
   
2.     Dim sFile, wbThis As Workbook, wbSrc As Workbook
   
3.     Dim lRowIndex As Long, lColIndex As Long, oDic As Object, aTime, sDate
   
4.     Dim sType As String, lShIndex As Long
   
5.         
   
6.     Const lBlkWidth As Long = 13
   
7.     Const lBlkHeight As Long = 36
   
8.    
   
9.     sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls),*.xls", Title:="選擇檔案")
   
10.     If StrComp(TypeName(sFile), "Boolean", vbTextCompare) = 0 Then Exit Sub
    
11.         
    
12.     Application.ScreenUpdating = False
    
13.     Set wbThis = ThisWorkbook
    
14.     Set wbSrc = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
    
15.     Set oDic = CreateObject("Scripting.Dictionary")
    
16.    
    
17.     With wbSrc.Sheets(1)
    
18.         sDate = .Range("TitleDate").Value
    
19.         aTime = .[A6].Resize(24).Value
    
20.         For lRowIndex = .[A2].Row To .UsedRange.Rows.Count Step lBlkHeight
    
21.             For lColIndex = 2 To lBlkWidth
    
22.                 sType = .Cells(lRowIndex, lColIndex).Value
    
23.                 If sType <> "" And Left(sType, 1) <> "@" Then
    
24.                     oDic(sType) = .Cells(lRowIndex, lColIndex).Offset(4).Resize(24).Value
    
25.                 End If
    
26.             Next
    
27.         Next
    
28.     End With
    
29.     wbSrc.Close
    
30.     Application.ScreenUpdating = True
    
31.    
    
32.     With wbThis
    
33.         For lShIndex = 1 To .Sheets.Count
    
34.             With .Sheets(lShIndex)
    
35.                 lRowIndex = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
    
36.                 .Cells(lRowIndex, "A").Value = sDate
    
37.                 .Cells(lRowIndex, "B").Resize(24) = aTime
    
38.                 For lColIndex = 3 To .[C4].End(xlToRight).Column
    
39.                     If oDic.exists(.Cells(4, lColIndex).Value) Then
    
40.                         .Cells(lRowIndex, lColIndex).Resize(24).Value = oDic(.Cells(4, lColIndex).Value)
    
41.                         oDic.Remove .Cells(4, lColIndex).Value
    
42.                     End If
    
43.                 Next
    
44.             End With
    
45.         Next
    
46.     End With
    
47.    
    
48.     MsgBox "目標檔找不到欄位的資料: " & vbCrLf & Join(oDic.keys, ", ")
    
49. End Sub

複製代碼

rockrun

回復 4# stillfish00

非常感謝 stillfish00 大大的幫忙

如果要取固定時間值的話該怎麼做(如 00:00、04:00、08:00、......之類)

stillfish00

回復 5# rockrun
試試看

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

複製代碼

rockrun

回復 6# stillfish00

感謝 stillfish00 大大的幫忙

大致問題都解決了，非常感謝:'(