Board logo

標題: [發問] 請問來源資料自動判定時間輸入相應的sheet內 [打印本頁]
作者: rockrun    時間: 2013-12-4 22:48     標題: 請問來源資料自動判定時間輸入相應的sheet內

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

有兩個來源檔資料要匯入相應的工作表中
[attach]16965[/attach]
[attach]16966[/attach]
來源檔的中的1、2和B2~M2、B38~M38、B74~M74.....抬頭名稱和目的檔3的B4~BT4抬頭名稱相同但"工作表"不同

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

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

[attach]16963[/attach]
作者: stillfish00    時間: 2013-12-4 23:24

本帖最後由 stillfish00 於 2013-12-4 23:26 編輯

回復 1# rockrun
抬頭名稱和目的檔不同呢，像B38 或 B74 ....
作者: rockrun    時間: 2013-12-4 23:31

本帖最後由 rockrun 於 2013-12-4 23:33 編輯

回復 2# stillfish00


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

[attach]16967[/attach]
作者: stillfish00    時間: 2013-12-5 07:58

回復 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    時間: 2013-12-5 12:03

回復 4# stillfish00

非常感謝 stillfish00 大大的幫忙

如果要取固定時間值的話該怎麼做(如 00:00、04:00、08:00、......之類)
作者: stillfish00    時間: 2013-12-5 15:10

回復 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    時間: 2013-12-5 19:28

回復 6# stillfish00

感謝 stillfish00 大大的幫忙

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)