ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

§ì¨ú¨Ó·½¸ê®Æ¥t¦s¦b¥Øªº¤£¦Psheet¤¤

§ì¨ú¨Ó·½¸ê®Æ¥t¦s¦b¥Øªº¤£¦Psheet¤¤

¦U¦ì¥ý¶i­Ì¦n

¤p§Ì¦³´X­Ó¨Ó·½¤å¥ó(ÀɦW¬Û¦Psheet¤º®e¤£¦P)¡AÁÙ¦³¤@­Ó¥Øªº¤å¥ó¤À¦¨¦n´X­Ósheet(¦Usheet¤¤¦U¦³¹ïÀ³¨Ó·½ÀÉ)¡A¨Ã«ü©w¿é¤J­nªº®É¶¡¶×¤J

¦³­Ó¤p°ÝÃD
1.Ū¨ú¨Ó·½ÀÉ¥H°}¦CŪ¨ú§¹«á©¹¤U¤@¦CÄ~Äò¤£¬O©¹¤U¤@ÄæÄ~Äò¡A¦pªG§Úªº°}¦CÃþ«¬¬OÄæ¦C³£¦³ªº¸Ü¡C
2.Ū¨ú§¹­n¼g¤J¥ØªºÀɮɷ|¼g¤J¥þ³¡sheet(·|¦bA1¼g¤J¤é´ÁB2¼g¤J®É¶¡¨ä¾lªÅ¥Õ) ¦Ó¤£¬O¥u¼g¤J¨ä¤¤¤@­Ósheet¤º

½Ð°Ý¦U¦ì¥ý¶i¸Ó¦p¦ó§ó§ï
  1. '¨C¤é³øªí¶×¤JÁ`¤é³øªí'

  2. Sub Test()
  3.     Dim sFile, wbThis As Workbook, wbSrc As Workbook
  4.     Dim lRowIndex As Long, lColIndex As Long, oDic As Object, aTime, sDate
  5.     Dim sType As String, lShIndex As Long, lTimeIndex As Long

  6.     Const lBlkWidth As Long = 13
  7.     Const lBlkHeight As Long = 40

  8.     sFile = Application.GetOpenFilename(fileFilter:="Excel Files (*.xls),*.xls", Title:="¿ï¾Ü¤é³øªí")
  9.     If StrComp(TypeName(sFile), "Boolean", vbTextCompare) = 0 Then Exit Sub

  10.     aTime = InputBox("¿é¤J­n°O¿ýªº®É¶¡" & "¥H³r¸¹¤À¶}¡A¤£­nªÅ®æ)", , "00:00,08:00,16:00")
  11.     If aTime = "" Then Exit Sub
  12.     aTime = Split(aTime, ",")

  13.     Application.ScreenUpdating = False
  14.     Set wbThis = ThisWorkbook
  15.     Set wbSrc = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
  16.     Set oDic = CreateObject("Scripting.Dictionary")

  17.     With wbSrc.Sheets(1)
  18.         sDate = .Range("TitleDate").Value
  19.         For lRowIndex = .[A8].Row To .UsedRange.Rows.Count Step lBlkHeight
  20.              For lColIndex = 2 To lBlkWidth
  21.                 sType = .Cells(lRowIndex, lColIndex).Value
  22.                     If sType <> "" And Left(sType, 1) <> "@" Then
  23.                         If Not oDic.exists(sType) Then
  24.                         Set oDic(sType) = CreateObject("scripting.dictionary")
  25.                         For Each x In .Cells(lRowIndex, 1).Offset(4).Resize(24)
  26.                             If x.Value <> "" Then oDic(sType)(x.Text) = x.Offset(, lColIndex - 1).Value
  27.                         Next
  28.                     End If
  29.                 End If
  30.             Next
  31.         Next
  32.     End With
  33.     wbSrc.Close
  34.     Application.ScreenUpdating = True

  35.     With wbThis
  36.         For lShIndex = 1 To .Sheets.Count
  37.             With .Sheets(lShIndex)
  38.                 lRowIndex = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
  39.                     .Cells(lRowIndex, "A").Value = sDate
  40.                     .Cells(lRowIndex, "B").Resize(UBound(aTime) + 1) = Application.Transpose(aTime)
  41.                 For lColIndex = 3 To .[C4].End(xlToRight).Column
  42.                     If oDic.exists(.Cells(4, lColIndex).Value) Then
  43.                         For lTimeIndex = 0 To UBound(aTime)
  44.                             .Cells(lRowIndex, lColIndex).Offset(lTimeIndex).Value = oDic(.Cells(4, lColIndex).Value)(aTime(lTimeIndex))
  45.                         Next
  46.                         oDic(.Cells(4, lColIndex).Value).RemoveAll
  47.                         oDic.Remove .Cells(4, lColIndex).Value
  48.                     End If
  49.                 Next
  50.             End With
  51.         Next
  52.     End With

  53.     MsgBox "¥Ø¼ÐÀɧ䤣¨ìÄæ¦ì¸ê®Æ: " & vbCrLf & Join(oDic.keys, ", ")
  54.     'cleanup
  55.     For Each x In oDic
  56.         oDic(x).RemoveAll
  57.         oDic.RemoveAll
  58.     Next
  59. End Sub
½Æ»s¥N½X

Test.rar (482.61 KB)

        ÀR«ä¦Û¦b : ¤£­n¤p¬Ý¦Û¤v¡A¦]¬°¤H¦³µL­­ªº¥i¯à¡C
ªð¦^¦Cªí ¤W¤@¥DÃD