自動【判讀有標示指定底色的數字次數】&【次數加總】&【輸出檔案】之語法。
- 帖子
- 315
- 主題
- 51
- 精華
- 0
- 積分
- 367
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office2003
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-9-29
- 最後登錄
- 2021-10-12
|
本帖最後由 Airman 於 2019-5-4 14:46 編輯
回復 10# Scott090
Scott090大大:您好!
1. 檔案以 日期序 做分類; 與 X-Y 無關 ==> OK! 8#的補充說明~請"忽略"即可。
2. 同一分類內每一個檔案都做相同的統計規則,
統計規則:
..........
..........
統計規則:不對!
規則重點整理~謹請參考~
統計範圍:
1_檔案內工作表的Cells([B65536].End(xlUp).Row) <10(即最後有數字的列數小於第10列)的檔案略過不計。
2_搜尋統計的範圍從第2列(即第一列標題的數字不在計算範圍)到Cells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)。
統計規則:
單一個(即有標示40號底色)是指︰檔案內的工作表之
當Cells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)有顯示數字(即<>""),
但Cells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)的同欄沒有數字(即="")
或
當Cells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)=第2列時,某欄有顯示數字(即<>""),
連2個(即有標示39號底色)是指︰檔案內的工作表之
當Cells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)有顯示數字(即<>""),
且Cells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)的同欄也有數字(即<>"")
但Cells([B65536].End(xlUp).Row - 10, 2).Resize(1, 49)的同欄沒有數字(即="")
或
當Cells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)=第3列時,某欄有顯示數字(即<>""),
且Cells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)的同欄也有數字(即<>"")
連3個(即有標示45號底色)是指︰檔案內的工作表之
當Cells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)有顯示數字(即<>""),
且Cells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)的同欄也有數字(即<>"")
且Cells([B65536].End(xlUp).Row - 10, 2).Resize(1, 49)的同欄也有數字(即<>"")
但Cells([B65536].End(xlUp).Row - 11, 2).Resize(1, 49)的同欄沒有數字(即="")
或
當Cells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)=第4列時,某欄有顯示數字(即<>""),
且Cells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)的同欄也有數字(即<>"")
且Cells([B65536].End(xlUp).Row - 10, 2).Resize(1, 49)的同欄也有數字(即<>"")
其餘連4個,....,連6個以此類推。
連7個(即有標示8號底色)是指︰檔案內的工作表之
當Cells([B65536].End(xlUp).Row - 8, 2).Resize(1, 49)有顯示數字(即<>""),
且Cells([B65536].End(xlUp).Row - 9, 2).Resize(1, 49)的同欄也有數字(即<>"")
且Cells([B65536].End(xlUp).Row - 10, 2).Resize(1, 49)的同欄也有數字(即<>"")
且Cells([B65536].End(xlUp).Row - 11, 2).Resize(1, 49)的同欄也有數字(即<>"")
且Cells([B65536].End(xlUp).Row - 12, 2).Resize(1, 49)的同欄也有數字(即<>"")
且Cells([B65536].End(xlUp).Row - 13, 2).Resize(1, 49)的同欄也有數字(即<>"")
且Cells([B65536].End(xlUp).Row - 14, 2).Resize(1, 49)的同欄也有數字(即<>"") |
|
|
|
|
|
|
- 帖子
- 2843
- 主題
- 10
- 精華
- 0
- 積分
- 2899
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2025-6-9
|
12#
發表於 2019-5-4 17:38
| 只看該作者
本帖最後由 准提部林 於 2019-5-4 19:00 編輯
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
與模擬結果不同, 僅以 "儲存格底色" 及 "數字" 為判別,
今日總表(均值排序).rar (71.11 KB)
|
|
|
|
|
|
|
- 帖子
- 315
- 主題
- 51
- 精華
- 0
- 積分
- 367
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office2003
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-9-29
- 最後登錄
- 2021-10-12
|
14#
發表於 2019-5-4 22:24
| 只看該作者
回復 12# 准提部林
准大:您好!
測試成功~感恩^^
您說的沒有錯~
' If R < 10 Then xB.Close 0: GoTo 101
改為
If R < 2 Then xB.Close 0: GoTo 101 '照模擬應該用這一行
答案才是正確的。謝謝您^^ |
|
|
|
|
|
|
- 帖子
- 315
- 主題
- 51
- 精華
- 0
- 積分
- 367
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office2003
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-9-29
- 最後登錄
- 2021-10-12
|
15#
發表於 2019-5-4 22:35
| 只看該作者
回復 13# Scott090
Scott090大大:您好!
不好意思,2個"統計"檔為2007版無法開啟核對答案;
主程式檔點執行鍵~沒有反應^^" |
|
|
|
|
|
|
- 帖子
- 315
- 主題
- 51
- 精華
- 0
- 積分
- 367
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office2003
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-9-29
- 最後登錄
- 2021-10-12
|
16#
發表於 2019-5-4 22:54
| 只看該作者
本帖最後由 Airman 於 2019-5-4 23:01 編輯
回復 13# Scott090
Scott090大大:您好!
不好意思,沒有注意到您程式寫在模組1^^"
在執行檔添加Main
已可正確執行。
執行後~答案正確~測試成功~感恩^^
特別感謝您的文字註解^^ |
|
|
|
|
|
|
- 帖子
- 315
- 主題
- 51
- 精華
- 0
- 積分
- 367
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office2003
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-9-29
- 最後登錄
- 2021-10-12
|
18#
發表於 2019-5-5 17:20
| 只看該作者
|
|
|
|
|
|
- 帖子
- 315
- 主題
- 51
- 精華
- 0
- 積分
- 367
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office2003
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-9-29
- 最後登錄
- 2021-10-12
|
19#
發表於 2019-5-5 17:29
| 只看該作者
本帖最後由 Airman 於 2019-5-5 17:41 編輯
回復 17# Scott090
Scott090大大:您好!
不好意思,因為後來才知道貴解答檔;必須將要判讀的所有檔案名稱與日期,全部先登錄在"FileNameSh"的A欄和B欄才能執行,
所以目前還在研究怎麼修改?暫時沒有再測試了^^"
准大的解答檔,有試過200個檔案~感覺是1分多鐘~因為沒有加寫計時碼,所以不知正確的耗時是多少?^^ |
|
|
|
|
|
|
- 帖子
- 529
- 主題
- 56
- 精華
- 0
- 積分
- 607
- 點名
- 149
- 作業系統
- win 10
- 軟體版本
- []
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-3-19
- 最後登錄
- 2025-6-23
           
|
20#
發表於 2019-5-5 21:07
| 只看該作者
本帖最後由 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 |
|
|
|
|
|
|