自動【判讀有標示指定底色的數字次數】&【次數加總】&【輸出檔案】之語法。
- 帖子
- 533
- 主題
- 58
- 精華
- 0
- 積分
- 613
- 點名
- 261
- 作業系統
- win 10
- 軟體版本
- []
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-3-19
- 最後登錄
- 2026-11-1
             
|
本帖最後由 Scott090 於 2019-5-5 21:16 編輯
回復 19# Airman
抱歉，試運轉後沒有 remark ' 拿掉。
不用人工入檔名
請重試
Option Explicit
Option Base 1
''===================
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% '底色數
colorNo = 7
colNo = 49
ReDim arDATA(colorNo, colNo)
Application.ScreenUpdating = False
fpath = ThisWorkbook.Path
'取得欲評估的檔案
'================
getFileNames
'取儲存格底色表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
NextFile:
wb.Close (fpath & "\" & sh.Cells(fileNo, 1))
Set wb = Nothing
fileNo = fileNo + 1
Loop
GoSub FinishCatFile 'For the last one date code catagory
Exit Sub
FinishCatFile:
With shSample
.[b2].Resize(colorNo, colNo) = arDATA
.Copy
End With
Sheets("Sample").Name = "今日總表(均值排序) - " & Cat & "_統計"
On Error Resume Next
Kill fpath & "\" & "今日總表(均值排序)-" & Cat & "_統計.xls"
On Error GoTo 0
ActiveWorkbook.Close savechanges:=True, Filename:=fpath & "\" & "今日總表(均值排序)-" & Cat & "_統計.xls"
ReDim arDATA(colorNo, colNo) 'clear contents
Application.ScreenUpdating = True
Return
End Sub
'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 |
|
|
|
|
|
|
|
發表於 2019-5-3 11:20
| 
