返回列表 上一主題 發帖

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

rockrun

帖子
8 
主題
4 
精華
0 
積分
55 
點名
0  
作業系統
Windows 10 
軟體版本
Office 2013 
閱讀權限
20 
性別
男 
註冊時間
2013-11-29 
最後登錄
2021-11-17 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2014-7-2 12:20 | 只看該作者

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

各位先進們好

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

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

請問各位先進該如何更改
  1. '每日報表匯入總日報表'

  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

  8.     Const lBlkWidth As Long = 13
  9.     Const lBlkHeight As Long = 40

  11.     sFile = Application.GetOpenFilename(fileFilter:="Excel Files (*.xls),*.xls", Title:="選擇日報表")
  12.     If StrComp(TypeName(sFile), "Boolean", vbTextCompare) = 0 Then Exit Sub

  14.     aTime = InputBox("輸入要記錄的時間" & "以逗號分開，不要空格)", , "00:00,08:00,16:00")
  15.     If aTime = "" Then Exit Sub
  16.     aTime = Split(aTime, ",")

  18.     Application.ScreenUpdating = False
  19.     Set wbThis = ThisWorkbook
  20.     Set wbSrc = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
  21.     Set oDic = CreateObject("Scripting.Dictionary")

  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

  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

  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
複製代碼

Test.rar (482.61 KB)

收藏 分享

        靜思自在 : 虛空有盡．我願無窮，發願容易行願難。
返回列表 上一主題