返回列表 上一主題 發帖

[發問] 判讀&填入次數的語法。

[發問] 判讀&填入次數的語法。

本帖最後由 Airman 於 2019-10-7 10:45 編輯

想將主檔程式碼列20~列23改為如下列的需求~
需求︰
1_判讀每一個測試檔的"空數列([A65536].End(xlUp).Row - 6)"之最大數值(即有標示38號底色的數字),
並依序填入"49_今日總表-(####-##-##)_空數統計表"的同號碼"空數列最大次數"之儲存格;
然後將每一個測試檔的對應"機數列([A65536].End(xlUp).Row - 4)"的數字,填入同欄之下一個的儲存格。
PS︰每一組數字,間隔一空白列。

2_當對應的"機數列"之數字是為該列最小數值(即有標示40號底色的數字)時,
則將填入該數字的"49_今日總表-(####-##-##)_空數統計表"之儲存格標示40號底色。

3_第2項有標示40號底色的數字=0時,則再將該數字標示3號字顏。

以上需求敬請各位大大惠予賜教!謝謝!
範例附檔 :   49_今日總表(空數統計).rar (73.15 KB)

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

TOP

回復 2# Airman
2樓的程式碼源自~
http://forum.twbts.com/viewthrea ... a=pageD1&page=2
12樓和32樓的程式碼。
謹供參考!謝謝!

TOP

本帖最後由 Airman 於 2019-10-18 00:11 編輯

回復 1# Airman
49_今日總表(空數統計)_V2.rar (74.4 KB)
重述需求︰
因為將Sample的格式更改為如附件的主檔"Sample"工作表,
所以更改相關的對應需求如下~
1_將原搜尋每一個判讀測試檔的Range("B2"&[A65536].End(xlUp).Row - 8, "AX2"&[A65536].End(xlUp).Row - 14)"範圍,
改為
Range("B2"&[A65536].End(xlUp).Row - 6, "AX2"&[A65536].End(xlUp).Row - 6)  =>即"空數"列。

2_將原搜尋每一個判讀測試檔的目標值之邏輯條件
改為
搜尋"空數"列的最大值  =>即有標示"38號"底色的數字;

3_將上述"空數"列的最大值依序填入"49_今日總表-(####-##-##)_空數統計表"的同號碼"空數列最大次數"(第2列)之儲存格;
然後將每一個測試檔的Range("B2"&[A65536].End(xlUp).Row - 4, "AX2"&[A65536].End(xlUp).Row - 4)之對應"機數"列的數字,填入同欄之下一個(第3列)的儲存格。

如果有某個號碼有2組(含)以上的數值時,則間隔一列繼續填入。

4_當對應的"機數列"之數字是為該測試檔機數列的最小數值(即有標示40號底色的數字)時,
則將填入該數字的"49_今日總表-(####-##-##)_空數統計表"之儲存格標示40號底色。

5_當第4項有標示40號底色的數字=0時,則再將該數字標示3號字顏。

以上需求敬請各位大大惠予賜教!謝謝!

TOP

回復 4# Airman

眼力大不如前, 看太多資料及文字太吃力,
現在若有簡單的題, 還可解答一二吧~~
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 5# 准提部林
准大:
感謝回應^^
如果是這樣,那這一題就當作是幫小弟的"最後一次忙"~感恩^^"

TOP

沒驗證:
49_今日總表(空數統計)_V2.rar (82.67 KB)
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 7# 准提部林
1021_空數統計表.rar (95.42 KB)
准大︰
感謝回覆^^

不好意思,以日期別分辨,產生多個日期的效果檔之需求效能不見了,可否請您再補充賜正?
EX︰範例附件中的"49_今日總表-(2019-09-20)_空數統計表"跑不出來,只能跑出"49_今日總表-(2019-10-01)_空數統計表"。
謝謝您!

TOP

回復 8# Airman


今日有點空, 一髮動全身!!!!
49_今日總表(空數統計)_V3.rar (103.29 KB)
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 9# 准提部林
准大 :
不好意思,因為是提問檔原本就有的效能,所以沒有再特別說明^^"

測試OK了!~感恩

TOP

        靜思自在 : 君子立恆志,小人恆立志。
返回列表 上一主題