- 帖子
- 835
- 主題
- 6
- 精華
- 0
- 積分
- 915
- 點名
- 16
- 作業系統
- Win 10,7
- 軟體版本
- 2019,2013,2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2010-5-3
- 最後登錄
- 2024-11-14
|
4#
發表於 2016-5-19 22:26
| 只看該作者
回復 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 ' 記錄最後列號
-
- 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 = "數量"
- .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) ' 數量
- wsTar.Cells(lRow, iCol + 1) = .Cells(lRC, 3) ' 日期
- End If
- lRC = lRC + 1
- Wend
- End With
- End Sub
 本文.zip (54.86 KB)
|
|
