- ©«¤l
- 835
- ¥DÃD
- 6
- ºëµØ
- 0
- ¿n¤À
- 915
- ÂI¦W
- 13
- §@·~¨t²Î
- Win 10,7
- ³nÅ骩¥»
- 2019,2013,2003
- ¾\ŪÅv
- 50
- ©Ê§O
- ¨k
- µù¥U®É¶¡
- 2010-5-3
- ³Ì«áµn¿ý
- 2024-10-25
|
¦^´_ 3# abc9gad2016
¸Õ¸Õ¬Ý:- Sub nn()
- Dim iCol%
- Dim lRC&, lRow&, lRows&
- Dim sPath$, sStr$
- Dim bNFind As Boolean, bCor As Boolean
- Dim dDte As Date
- Dim vdPdt, vdDte
- Dim wbSou As Workbook, wsSou As Worksheet, wsTar As Worksheet
-
- sPath = ThisWorkbook.Path
- ChDrive sPath
- ChDir sPath
- Set vdPdt = CreateObject("Scripting.Dictionary")
- Set vdDte = CreateObject("Scripting.Dictionary")
- Set wsTar = Workbooks("¥»¤å.xls").Sheets(1)
-
- bNFind = True
- For Each wbSou In Workbooks
- If wbSou.Name = "³Æµù.xls" Then
- bNFind = False
- Exit For
- End If
- Next
-
- If bNFind Then
- Set wsSou = Workbooks.Open("³Æµù.xls").Sheets(1)
- Else
- Set wsSou = wbSou.Sheets(1)
- End If
-
- With wsTar
- .Activate
- lRC = 3
- While .Cells(lRC, 3) <> ""
- vdPdt(CStr(.Cells(lRC, 3))) = lRC
- lRC = lRC + 1
- Wend
- lRows = lRC ' °O¿ý³Ì«á¦C¸¹
-
- lRC = 3
- bCor = True
- dDte = #5/20/2016#
- While lRC <= Columns.Count - 7
- If Weekday(dDte) = 6 Then
- lRC = lRC + 4
- With .Cells(1, lRC)
- With .Offset(1).Offset(, 1)
- .Value = "¼Æ¶q"
- .Interior.ColorIndex = 35
- End With
- With .Offset(1).Offset(, 2)
- .Value = "¤é´Á"
- .Interior.ColorIndex = 35
- End With
- .Resize(, 4).Merge
- .Value = dDte
- .NumberFormat = "m" & Chr(34) & "¤ë" & Chr(34) & "d" & Chr(34) & "¤é" & Chr(34) & ";@" ' m"¤ë"d"¤é";@
- If bCor Then .Resize(Rows.Count, 4).Interior.ColorIndex = 35
- bCor = Not bCor
- End With
- vdDte(CStr(dDte)) = lRC
- Else
- vdDte(CStr(dDte)) = lRC
- End If
- dDte = dDte + 1
- Wend
- End With
-
- With wsSou
- lRC = 8
- While .Cells(lRC, 1) <> ""
- sStr = CStr(.Cells(lRC, 1))
- lRow = vdPdt(sStr)
- If lRow = 0 Then
- wsTar.Cells(lRows, 3) = sStr
- vdPdt(sStr) = lRows
- lRow = lRows
- lRows = lRows + 1
- End If
- sStr = .Cells(lRC, 3)
- sStr = Left(sStr, 3) + 1911 & "/" & CInt(Mid(sStr, 5, 2)) & "/" & CInt(Right(sStr, 2)) ' 2016/6/1
- iCol = vdDte(sStr) + 1
- If iCol <> 0 Then
- wsTar.Cells(lRow, iCol) = .Cells(lRC, 9) ' ¼Æ¶q
- wsTar.Cells(lRow, iCol + 1) = .Cells(lRC, 3) ' ¤é´Á
- End If
- lRC = lRC + 1
- Wend
- End With
- End Sub
½Æ»s¥N½X
¥»¤å.zip (54.86 KB)
|
|