- 帖子
- 315
- 主題
- 51
- 精華
- 0
- 積分
- 367
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office2003
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-9-29
- 最後登錄
- 2021-10-12
|
2#
發表於 2019-10-8 02:26
| 只看該作者
Private Sub CommandButton1_Click()
Dim BK As Workbook, F$, T$, xB As Workbook, xS As Worksheet
Dim xD, Arr(1 To 7, 1 To 49), Brr, R&, V, xR As Range, tim!
tim = Timer
[L1] = ""
Set BK = ThisWorkbook
Set xD = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Do
If F = "" Then F = Dir(BK.Path & "\*.xls") Else F = Dir()
If F = "" Then Exit Do
If Not F Like "49_均值排序-今日總表-*_*-(####-##-##).xls" Then GoTo 101
T = Left(Right(F, 16), 12)
Brr = xD(T)
If Not IsArray(Brr) Then xD(T) = Arr: Brr = Arr
'-----------------------------------------------
Set xB = Workbooks.Open(BK.Path & "\" & F, ReadOnly:=True): Set xS = xB.Sheets(1)
R = xS.[A65536].End(xlUp).Row - 8
If R < 12 Then xB.Close 0: GoTo 101 '總列數小於20,GoTo 101.
' For Each xR In xS.Cells(R, 2).Resize(1, 49) '列20
' V = InStr("---8--37-38-4--45-39-40-", "-" & xR.Interior.ColorIndex & "-") / 3
' If Val(xR) > 0 And V > 0 Then Brr(V, xR) = Brr(V, xR) + 1
' Next '列23
xD(T) = Brr: xB.Close 0
101: Loop
'----------------------------------------------------
If xD.Count = 0 Then Exit Sub
Application.DisplayAlerts = False
For Each V In xD.keys
F = "49_今日總表-" & V & "_空數統計表.xls"
BK.Sheets("Sample").Copy
With ActiveWorkbook
.Sheets(1).[B2].Resize(7, 49).Value = xD(V & "")
d$ = Format(Mid(V, 2, 10), "yyyy/m/d")
Set xR = Nothing
Set xR = BK.Sheets("DATA").[A:A].Find(d, Lookat:=xlPart)
If Not xR Is Nothing Then
For i = 4 To 9
.Sheets(1).Cells(1, xR(1, i) + 1).Font.ColorIndex = 10
.Sheets(1).Cells(1, xR(2, i) + 1).Interior.ColorIndex = 6
Next i
Sheets(1).Cells(1, xR(1, 10) + 1).Font.ColorIndex = 7
Sheets(1).Cells(1, xR(2, 10) + 1).Interior.ColorIndex = 8
End If
.SaveAs Filename:=BK.Path & "\" & F, CreateBackup:=False
.Close 0
End With
Next
[L1] = Format((Timer - tim) / 24 / 60 / 60, "hh:mm:ss")
End Sub |
|
發表於 2019-10-19 10:40
| 
