- ©«¤l
- 1018
- ¥DÃD
- 15
- ºëµØ
- 0
- ¿n¤À
- 1058
- ÂI¦W
- 0
- §@·~¨t²Î
- win7 32bit
- ³nÅ骩¥»
- Office 2016 64-bit
- ¾\ŪÅv
- 50
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ®ç¶é
- µù¥U®É¶¡
- 2012-5-9
- ³Ì«áµn¿ý
- 2022-9-28
|
¦^´_ 5# rockrun
¸Õ¸Õ¬Ý- Sub Test()
- Dim sFile, wbThis As Workbook, wbSrc As Workbook
- Dim lRowIndex As Long, lColIndex As Long, oDic As Object, aTime, sDate
- Dim sType As String, lShIndex As Long, lTimeIndex As Long
-
- Const lBlkWidth As Long = 13
- Const lBlkHeight As Long = 36
-
- sFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls),*.xls", Title:="¿ï¾ÜÀÉ®×")
- If StrComp(TypeName(sFile), "Boolean", vbTextCompare) = 0 Then Exit Sub
-
- aTime = InputBox("¿é¤Jn°O¿ýªº®É¶¡" & "(¥H³r¸¹¤À¶}¡A¤£nªÅ®æ)", , "00:00,04:00,08:00")
- If aTime = "" Then Exit Sub
- aTime = Split(aTime, ",")
-
- Application.ScreenUpdating = False
- Set wbThis = ThisWorkbook
- Set wbSrc = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
- Set oDic = CreateObject("Scripting.Dictionary")
-
- With wbSrc.Sheets(1)
- sDate = .Range("TitleDate").Value
- For lRowIndex = .[A2].Row To .UsedRange.Rows.Count Step lBlkHeight
- For lColIndex = 2 To lBlkWidth
- sType = .Cells(lRowIndex, lColIndex).Value
- If sType <> "" And Left(sType, 1) <> "@" Then
- If Not oDic.exists(sType) Then
- Set oDic(sType) = CreateObject("scripting.dictionary")
- For Each x In .Cells(lRowIndex, 1).Offset(4).Resize(24)
- If x.Value <> "" Then oDic(sType)(x.Text) = x.Offset(, lColIndex - 1).Value
- Next
- End If
- End If
- Next
- Next
- End With
- wbSrc.Close
- Application.ScreenUpdating = True
-
- With wbThis
- For lShIndex = 1 To .Sheets.Count
- With .Sheets(lShIndex)
- lRowIndex = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
- .Cells(lRowIndex, "A").Value = sDate
- .Cells(lRowIndex, "B").Resize(UBound(aTime) + 1) = Application.Transpose(aTime)
- For lColIndex = 3 To .[C4].End(xlToRight).Column
- If oDic.exists(.Cells(4, lColIndex).Value) Then
- For lTimeIndex = 0 To UBound(aTime)
- .Cells(lRowIndex, lColIndex).Offset(lTimeIndex).Value = oDic(.Cells(4, lColIndex).Value)(aTime(lTimeIndex))
- Next
- oDic(.Cells(4, lColIndex).Value).RemoveAll
- oDic.Remove .Cells(4, lColIndex).Value
- End If
- Next
- End With
- Next
- End With
-
- MsgBox "¥Ø¼ÐÀɧ䤣¨ìÄæ¦ìªº¸ê®Æ: " & vbCrLf & Join(oDic.keys, ", ")
- 'cleanup
- For Each x In oDic
- oDic(x).RemoveAll
- oDic.Remove
- Next
½Æ»s¥N½X |
|