12345
返回列表 上一主題 發帖

自動【判讀有標示指定底色的數字次數】&【次數加總】&【輸出檔案】之語法。

Airman

帖子
315 
主題
51 
精華
0 
積分
367 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-29 
最後登錄
2021-10-12 
11# 跳轉到 »
發表於 2019-5-4 14:39 | 只看該作者
本帖最後由 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)的同欄也有數字(即<>"")

TOP

准提部林

帖子
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)

TOP

Scott090

帖子
529 
主題
56 
精華
0 
積分
607 
點名
145  
作業系統
win 10 
軟體版本
[] 
閱讀權限
50 
性別
男 
註冊時間
2013-3-19 
最後登錄
2025-6-19 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章論壇榮譽勳章論壇贊助勳章2015羊年全勤獎章
13#
發表於 2019-5-4 21:43 | 只看該作者
回復 11# Airman

   試看看是否符合需求
          今日總表(均值排序).rar (90.38 KB)

TOP

Airman

帖子
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  '照模擬應該用這一行
答案才是正確的。謝謝您^^

TOP

Airman

帖子
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版無法開啟核對答案；
主程式檔點執行鍵~沒有反應^^"

TOP

Airman

帖子
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
已可正確執行。

執行後~答案正確~測試成功~感恩^^

特別感謝您的文字註解^^

TOP

Scott090

帖子
529 
主題
56 
精華
0 
積分
607 
點名
145  
作業系統
win 10 
軟體版本
[] 
閱讀權限
50 
性別
男 
註冊時間
2013-3-19 
最後登錄
2025-6-19 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章論壇榮譽勳章論壇贊助勳章2015羊年全勤獎章
17#
發表於 2019-5-5 08:02 | 只看該作者
回復 16# Airman


    是否可告知實際上鑑別辨識了幾百個檔案，用了多少時間呢?

TOP

Airman

帖子
315 
主題
51 
精華
0 
積分
367 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-29 
最後登錄
2021-10-12 
18#
發表於 2019-5-5 17:20 | 只看該作者
本帖最後由 Airman 於 2019-5-5 17:21 編輯

回復 12# 准提部林





准大︰您好!
不好意思，能再幫小弟加一個指定日期的開獎號碼嗎^^"

說明︰
當統計檔案的日期=DATA的A欄日期時，
則將統計檔案內的"Sample"工作表之$B$1︰$AX$1有出現該A欄日期的D︰J的數字標示底色~
=D︰K的數字標示6號底色；=J的數字標示43號底色。
如該DATA的A欄日期的D︰J=""(即沒有出現數字)，則都不標示底色。

PS︰因為DATA和檔案名稱是由2個不同軟體下載的，所以不同~
如果這樣編寫會很麻煩，就請將DATA的A欄日期格式改為與統計檔案名稱的日期格式相同。

謝謝您^^

今日總表(均值排序)_T.rar (93.76 KB)

TOP

Airman

帖子
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分多鐘~因為沒有加寫計時碼，所以不知正確的耗時是多少?^^

TOP

Scott090

帖子
529 
主題
56 
精華
0 
積分
607 
點名
145  
作業系統
win 10 
軟體版本
[] 
閱讀權限
50 
性別
男 
註冊時間
2013-3-19 
最後登錄
2025-6-19 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章論壇榮譽勳章論壇贊助勳章2015羊年全勤獎章
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

TOP

        靜思自在 : 一句溫暖的話，就像往別人身上灑香水，自己會沾到兩三滴。
12345
返回列表 上一主題