返回列表 上一主題 發帖

[發問] 浮點數運算處理，在VBA 程式中去呼叫WORKSHEET的ROUND

Hsieh

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

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2013-10-29 15:21 | 顯示全部帖子
回復 1# jj369963
  1. Sub Replace_Blank()

  3. Columns("A:A").Select


  6.     Selection.Insert Shift:=xlToRight
  7.     Selection.Insert Shift:=xlToRight


  10. Range("A1").Select
  11.     ActiveCell.FormulaR1C1 = "password"

  13.     Range("B1").Select
  14.     ActiveCell.FormulaR1C1 = "user"


  17.     Dim E As Range
  18.     For Each E In Range("f:f").SpecialCells(xlCellTypeConstants)
  19.         E.Value = "'" & Replace(E, ",", "")
  20.     Next


  23. With [H:BC]
  24. .Replace "*,*", "", xlWhole '清除複選
  25. End With
  26. With [H:BC] '1~48題的欄位


  29. .Replace 1, "3@", xlWhole '將1用一個不常用符號取代


  32. .Replace 2, 1, xlWhole '將2用1取代


  35. .Replace 3, 2, xlWhole '將3用2取代


  38. .Replace "3@", 3, xlWhole '將不常用符號用3取代


  41. End With
  42. Dim A As Range, Ar(), B As Range
  43. Set Upw = CreateObject("Scripting.Dictionary") '帳密
  44. Set dic = CreateObject("Scripting.Dictionary") '參照
  45. fs = ThisWorkbook.Path & "\replace_rule.txt" 'TEXT檔案位置
  46. Close #1 '若已經開啟就先關閉
  47. With Sheets("Sheet0")
  48. Open fs For Input As #1
  49. Do Until EOF(1)
  50.    Line Input #1, mystr
  51.    If InStr(mystr, ",") > 0 Then
  52.    s = InStr(mystr, "(")
  53.    n = InStr(s, mystr, ")")
  54.    mystr = Mid(mystr, s + 1, n - s - 1)
  55.    For Each C In Split(mystr, ",")
  56.      Set A = .Rows(1).Find(C)
  57.      ReDim Preserve Ar(i)
  58.      Ar(i) = Split(A.Address, "$")(1)
  59.      i = i + 1
  60.    Next
  61.    For Each p In Ar
  62.       dic(p) = Ar '記錄公式參照欄位
  63.    Next
  64.    Erase Ar: i = 0
  65.    End If
  66. Loop
  67. Close #1
  68. With Sheets("Sheet1")
  69.   For Each A In .Range(.[A2], .[A2].End(xlDown))
  70.      Upw(CStr(A)) = Array(A.Offset(, 3).Value, A.Offset(, 2).Value) '記錄帳密
  71.   Next
  72. End With
  73. '取代複選位置
  74. Set A = .Range(.[H2], .Cells(.Rows.Count, "CQ").End(xlUp)).Find("*,*")
  75. If Not A Is Nothing Then
  76. Do
  77. ay = Split(A, ",")
  78. For i = 0 To UBound(ay)
  79. ReDim Preserve Ar(i)
  80. Ar(i) = Val(ay(i))
  81. Next
  82.   A.Value = Round(Application.Average(Ar), 0)
  83.   Erase Ar
  84.   Set A = .Range(.[H2], .Cells(.Rows.Count, "CQ").End(xlUp)).Find("*,*", A)
  85. Loop Until A Is Nothing
  86. End If
  87. i = 0
  88. .Select
  89. For Each A In .Range(.[F2], .Cells(.Rows.Count, "F").End(xlUp))
  90.    A.Offset(, -5).Resize(, 2) = Upw(CStr(A)) '填寫帳密
  91.    r = A.Row
  92.    For Each B In .Range(.Cells(r, "H"), .Cells(r, "CQ"))
  93.       If B = "" Then  '找到空格
  94.       ay = dic(Split(B.Address, "$")(1))
  95.       If Not IsEmpty(ay) Then '該儲存格有被公式引用
  96.          For i = 0 To UBound(ay)
  97.          If .Range(ay(i) & r) <> "" Then '引用的參照非空白才計入陣列
  98.            ReDim Preserve Ar(j)
  99.            Ar(j) = Range(ay(i) & r).Value
  100.            j = j + 1
  101.          End If
  102.          Next
  103.         If j > 0 Then B.Value = Application.Round(Application.WorksheetFunction.Average(Ar), 0)
  104.          Erase Ar
  105.          j = 0
  106.       End If
  107.       End If
  108.     Next
  109. Next
  110. End With

  112. Cells.Select
  113.     Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
  114.         "=(COUNTBLANK($A1:$CQ1)>0)*(COUNTA($A1:$CQ1)>0)"
  115.     Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
  116.     With Selection.FormatConditions(1).Interior
  117.         .PatternColorIndex = xlAutomatic
  118.         .ThemeColor = xlThemeColorAccent6
  119.         .TintAndShade = 0.399945066682943
  120.     End With
  121.     Selection.FormatConditions(1).StopIfTrue = True


  124. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 難行能行，難捨能捨，難為能為，才能昇華自我的人格。
返回列表 上一主題