123
返回列表 上一主題 發帖

[發問] (已解決)統計顏色次數

freeffly

帖子
586 
主題
123 
精華
0 
積分
763 
點名
0  
作業系統
WINDOW7 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-16 
最後登錄
2017-3-14 

熱烈參與勳章好學求知勳章
17# 跳轉到 »
發表於 2011-6-4 07:26 | 只看該作者
回復 16# Hsieh


    謝謝大大提供另外一種方式
   這個的迴圈好幾層
   感覺都快亂了→對我而言
可以問一下這兩句的意思嗎
first = Rng(1, i): i = i + 1
Cells(R, "AE") = cnt: cnt = 0

剩下的程式碼拆開都看得懂
不過還需要理解
字典兩各字 還真難理解

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
110  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-5-13 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
16#
發表於 2011-6-3 09:55 | 只看該作者
回復 15# freeffly


    直接判斷數值是否增加
  1. Sub ex()
  2. [AE:AE] = ""
  3. R = 5
  4. Do Until Cells(R, 2) = ""
  5. Set Rng = Range(Cells(R, 3), Cells(R, "AD"))
  6. i = 1
  7. Do Until Rng(1, i) <> ""
  8. i = i + 1
  9. Loop
  10. first = Rng(1, i): i = i + 1
  11. For k = i To Rng.Count
  12.   If Rng(1, k) > first Then cnt = cnt + 1
  13.   If Rng(1, k) <> "" Then first = Rng(1, k)
  14. Next
  15. Cells(R, "AE") = cnt: cnt = 0
  16. R = R + 1
  17. Loop
  18. End Sub
複製代碼
學海無涯_不恥下問

TOP

freeffly

帖子
586 
主題
123 
精華
0 
積分
763 
點名
0  
作業系統
WINDOW7 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-16 
最後登錄
2017-3-14 

熱烈參與勳章好學求知勳章
15#
發表於 2011-6-1 22:00 | 只看該作者
回復 14# GBKEE


    表達上可能有些不清楚
不過大大的方式我改過已經是我要的

只是不知道我這樣改事不是最佳的方式
附上我要的完成品
又學到新東西
謝謝
  1. Sub up()
  2.     Application.ScreenUpdating = False
  3.     Dim Rng As Range, X As Range, R As Range, Tolta%, A%, i%, ii%
  4.     With Cells
  5.         .Interior.ColorIndex = xlNone
  6.         .Font.ColorIndex = 0
  7.         .Font.Bold = False
  8.     End With
  9.     Set Rng = Range("C5:AD" & [A65536].End(xlUp).Row)
  10.     For Each R In Rng.Rows
  11.         Set Rng = R.Cells(1)
  12.         A = 0
  13.         Set Rng = R.Cells(1, 0).End(xlToRight)
  14.         Rng.Interior.ColorIndex = 0
  15.         Y = [iv4].End(xlToLeft).Column - 1
  16.         For ii = 2 To 28
  17.             If R.Cells(1, ii) <> "" And Rng < R.Cells(1, ii) Then
  18.                 Set Rng = R.Cells(1, ii)
  19.                 With R.Cells(1, ii).Font
  20.                     .ColorIndex = 7
  21.                     .Bold = True
  22.                 End With
  23.                 A = A + 1
  24.                 With R.Cells(1, Y)
  25.                     .Value = A
  26.                     .Interior.ColorIndex = 4
  27.                 End With
  28.             ElseIf R.Cells(1, ii) <> "" And Rng > R.Cells(1, ii) Then
  29.                 Set Rng = R.Cells(1, ii)
  30.             End If
  31.         Next
  32.     Next
  33. End Sub
複製代碼
統計顏色.rar (10.83 KB)
字典兩各字 還真難理解

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
14#
發表於 2011-6-1 20:15 | 只看該作者
回復 13# freeffly


是這樣嗎?
  1. Sub up()
  2.     Application.ScreenUpdating = False
  3.     Dim Rng As Range, R As Range, i%, ii%
  4.     With Cells
  5.         .Interior.ColorIndex = xlNone
  6.         .Font.ColorIndex = 0
  7.         .Font.Bold = False
  8.     End With
  9.     Set Rng = Range("C5:AD" & [A65536].End(xlUp).Row)
  10.     For Each R In Rng.Rows
  11.         A = 0
  12.         Set Rng = R.Cells(1, 0).End(xlToRight)
  13.         Rng.Interior.ColorIndex = 6
  14.         For ii = Rng.Column - 1 To 28
  15.             If R.Cells(ii) <> "" And Rng < R.Cells(ii) Then
  16.                 Set Rng = R.Cells(ii)
  17.                 With R.Cells(ii).Font
  18.                     .ColorIndex = 7
  19.                     .Bold = True
  20.                 End With
  21.                 A = A + 1
  22.             ElseIf R.Cells(ii) <> "" And Rng > R.Cells(ii) Then
  23.                 Set Rng = R.Cells(ii)
  24.             End If
  25.         Next
  26.         With R.Cells(1, 29)
  27.             .Value = A
  28.             .Interior.ColorIndex = 4
  29.         End With
  30.     Next
  31.     Set Rng = Nothing
  32.     Set R = Nothing
  33. End Sub
複製代碼

TOP

freeffly

帖子
586 
主題
123 
精華
0 
積分
763 
點名
0  
作業系統
WINDOW7 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-16 
最後登錄
2017-3-14 

熱烈參與勳章好學求知勳章
13#
發表於 2011-5-31 19:46 | 只看該作者
不知道我的附檔大大看的懂嗎?
字典兩各字 還真難理解

TOP

freeffly

帖子
586 
主題
123 
精華
0 
積分
763 
點名
0  
作業系統
WINDOW7 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-16 
最後登錄
2017-3-14 

熱烈參與勳章好學求知勳章
12#
發表於 2011-5-30 12:24 | 只看該作者
回復 11# GBKEE


    如附檔黃色標起來的地方不應該被認為漲價
      因為前面沒交易
       你提的那行程式碼我是要用來讓他直接在資料的右邊統計
    統計顏色.rar (6.6 KB)
字典兩各字 還真難理解

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
11#
發表於 2011-5-27 19:55 | 只看該作者
回復 9# freeffly
"可是我忘了還有第3、4....格 "  沒有啊
Y = [iv4].End(xlToLeft).Column - 1 作何用??
10樓的附檔不符合用於9樓的程式

回復10# freeffly

987


這條件 請還要詳述

TOP

freeffly

帖子
586 
主題
123 
精華
0 
積分
763 
點名
0  
作業系統
WINDOW7 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-16 
最後登錄
2017-3-14 

熱烈參與勳章好學求知勳章
10#
發表於 2011-5-27 17:43 | 只看該作者
如附檔中標註的那兩各位子
要怎樣讓程式碼不對這種情形做動作可是又不會影響到他後面的數字做動作

Book1.rar (3.96 KB)
字典兩各字 還真難理解

TOP

freeffly

帖子
586 
主題
123 
精華
0 
積分
763 
點名
0  
作業系統
WINDOW7 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-16 
最後登錄
2017-3-14 

熱烈參與勳章好學求知勳章
9#
發表於 2011-5-27 17:38 | 只看該作者
回復 7# GBKEE
  1. Sub up()
  2.     Application.ScreenUpdating = False
  3.     Dim Rng As Range, X As Range, R As Range, Tolta%, A%, i%, ii%
  4.     With Cells.Font
  5.         .ColorIndex = 0
  6.         .Bold = False
  7.     End With
  8.     Set Rng = Range("C5:AD" & [A65536].End(xlUp).Row)
  9.     For Each R In Rng.Rows
  10.         Set Rng = R.Cells(1)
  11.         A = 0
  12.         Y = [iv4].End(xlToLeft).Column - 1
  13.         For ii = 2 To 28
  14.             If R.Cells(1, ii) <> "" And Rng < R.Cells(1, ii) Then
  15.                 Set Rng = R.Cells(1, ii)
  16.                 With R.Cells(1, ii).Font
  17.                     .ColorIndex = 7
  18.                     .Bold = True
  19.                 End With
  20.                 A = A + 1
  21.                 With R.Cells(1, Y)
  22.                     .Value = A
  23.                     .Interior.ColorIndex = 4
  24.                 End With
  25.             ElseIf R.Cells(1, ii) <> "" And Rng > R.Cells(1, ii) Then
  26.                 Set Rng = R.Cells(1, ii)
  27.             End If
  28.             If R.Cells(1) = "" Then
  29.             With R.Cells(2).Font
  30.                 .ColorIndex = 0
  31.                 .Bold = False
  32.            End With
  33.            End If
  34.         Next
  35.     Next
  36. End Sub
複製代碼
  1.    If R.Cells(1) = "" Then
  2.             With R.Cells(2).Font
  3.                 .ColorIndex = 0
  4.                 .Bold = False
  5.            End With
  6.            End If
複製代碼
這一段原本是為了如果該行的第一格為空白第2格就不要做反應
可是我忘了還有第3、4....格
請問這各要怎麼修改?
字典兩各字 還真難理解

TOP

freeffly

帖子
586 
主題
123 
精華
0 
積分
763 
點名
0  
作業系統
WINDOW7 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-16 
最後登錄
2017-3-14 

熱烈參與勳章好學求知勳章
8#
發表於 2011-5-27 14:53 | 只看該作者
回復 7# GBKEE


    謝謝大大解說
     我在研究一下如何改成漲價的判斷
字典兩各字 還真難理解

TOP

        靜思自在 : 並非有錢魷是快樂，問心無愧心最安。
123
返回列表 上一主題