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
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 "今日總表(均值排序)-*_*-(####-##-##).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 < 10 Then xB.Close 0: GoTo 101
'If R < 2 Then xB.Close 0: GoTo 101 '照模擬應該用這一行
For Each xR In xS.Cells(R, 2).Resize(1, 49)
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
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 = "今日總表(均值排序)-" & V & "_統計.xls"
BK.Sheets("Sample").Copy
With ActiveWorkbook
.Sheets(1).[B2].Resize(7, 49).Value = xD(V & "")
.SaveAs Filename:=BK.Path & "\" & F, CreateBackup:=False
.Close 0
End With
Next
End Sub
''===================
Sub Main()
Dim wb As Workbook, sh As Worksheet, shSample As Worksheet, fpath$
Dim arColor%(7), arDATA
Dim i%, j%, k%, fileNo%, RowNo%, colNo%
Dim Cat$ '檔案系列代碼
Dim colorNo% '底色數
'取儲存格底色表CaeColor
'==================
Set shSample = ThisWorkbook.Sheets("Sample")
With shSample
colorNo = 7 '7種底色
For i = 1 To colorNo
arColor(colorNo - i + 1) = .Cells(i + 1, 1).Interior.ColorIndex
Next
End With
Set sh = ThisWorkbook.Sheets("FileNameSh")
fileNo = 1: Cat = sh.Cells(1, 2)
Do While sh.Cells(fileNo, 2) <> ""
If sh.Cells(fileNo, 2) <> Cat Then GoSub FinishCatFile: Cat = sh.Cells(fileNo, 2)
DoEvents
Application.ScreenUpdating = False
Set wb = Workbooks.Open(fpath & "\" & sh.Cells(fileNo, 1))
RowNo = [B65536].End(xlUp).Row
If RowNo < 10 Then GoTo NextFile '原規則設 Rowno <10 則不處理
RowNo = RowNo - 1 - colorNo
For i = 1 To colorNo '從 1 ~ 7 底色
For j = 1 To colNo '從 1~ 49 欄
For k = 0 To i - 1 '查核連續相同底色
If RowNo - k = 1 Then GoTo NextFile '檔案的有效列數比底色數少，Cells的列已到第1列
If Cells(RowNo - k, j + 1).Interior.ColorIndex <> arColor(i) Then GoTo NextCol
Next
arDATA(colorNo - i + 1, j) = arDATA(colorNo - i + 1, j) + 1
NextCol:
Next
NextColor:
Next
'To get all file names into a working sheet
'=============================
Sub getFileNames()
Dim fs, Cat$
Dim sh As Worksheet
Dim fpath$
Dim i%, j%, R%
fpath = ThisWorkbook.Path
On Error Resume Next
Set sh = Sheets("FileNameSh")
If Err.Number <> 0 Then Sheets.Add.Name = "FileNameSh": Set sh = ActiveSheet
On Error GoTo 0
sh.Cells.Clear
With sh
fs = Dir(fpath & "\*.*")
Do Until fs = ""
Cat = Left(Right(fs, 16), 12)
If InStr(Cat, "(2019") <> 0 Then
R = R + 1
.Cells(R, 1) = fs
.Cells(R, 2) = Cat
End If
fs = Dir
Loop
With .Sort
.SortFields.Add Key:=[B:B]
.SetRange sh.UsedRange
.Apply
End With
End With
End Sub作者: Airman 時間: 2019-5-5 22:07
第2段改為:
If xD.Count = 0 Then Exit Sub
Application.DisplayAlerts = False
For Each V In xD.keys
F = "今日總表(均值排序)-" & 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).Interior.ColorIndex = 6
Next i
Sheets(1).Cells(1, xR(1, 10) + 1).Interior.ColorIndex = 43
End If
.SaveAs Filename:=BK.Path & "\" & F, CreateBackup:=False
.Close 0
End With
Next
