- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 276
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2024-12-22
              
|
3#
發表於 2013-10-29 15:21
| 只看該作者
回復 1# jj369963 - Sub Replace_Blank()
- Columns("A:A").Select
- Selection.Insert Shift:=xlToRight
- Selection.Insert Shift:=xlToRight
- Range("A1").Select
- ActiveCell.FormulaR1C1 = "password"
- Range("B1").Select
- ActiveCell.FormulaR1C1 = "user"
- Dim E As Range
- For Each E In Range("f:f").SpecialCells(xlCellTypeConstants)
- E.Value = "'" & Replace(E, ",", "")
- Next
- With [H:BC]
- .Replace "*,*", "", xlWhole '清除複選
- End With
- With [H:BC] '1~48題的欄位
- .Replace 1, "3@", xlWhole '將1用一個不常用符號取代
- .Replace 2, 1, xlWhole '將2用1取代
- .Replace 3, 2, xlWhole '將3用2取代
- .Replace "3@", 3, xlWhole '將不常用符號用3取代
- End With
- Dim A As Range, Ar(), B As Range
- Set Upw = CreateObject("Scripting.Dictionary") '帳密
- Set dic = CreateObject("Scripting.Dictionary") '參照
- fs = ThisWorkbook.Path & "\replace_rule.txt" 'TEXT檔案位置
- Close #1 '若已經開啟就先關閉
- With Sheets("Sheet0")
- Open fs For Input As #1
- Do Until EOF(1)
- Line Input #1, mystr
- If InStr(mystr, ",") > 0 Then
- s = InStr(mystr, "(")
- n = InStr(s, mystr, ")")
- mystr = Mid(mystr, s + 1, n - s - 1)
- For Each C In Split(mystr, ",")
- Set A = .Rows(1).Find(C)
- ReDim Preserve Ar(i)
- Ar(i) = Split(A.Address, "$")(1)
- i = i + 1
- Next
- For Each p In Ar
- dic(p) = Ar '記錄公式參照欄位
- Next
- Erase Ar: i = 0
- End If
- Loop
- Close #1
- With Sheets("Sheet1")
- For Each A In .Range(.[A2], .[A2].End(xlDown))
- Upw(CStr(A)) = Array(A.Offset(, 3).Value, A.Offset(, 2).Value) '記錄帳密
- Next
- End With
- '取代複選位置
- Set A = .Range(.[H2], .Cells(.Rows.Count, "CQ").End(xlUp)).Find("*,*")
- If Not A Is Nothing Then
- Do
- ay = Split(A, ",")
- For i = 0 To UBound(ay)
- ReDim Preserve Ar(i)
- Ar(i) = Val(ay(i))
- Next
- A.Value = Round(Application.Average(Ar), 0)
- Erase Ar
- Set A = .Range(.[H2], .Cells(.Rows.Count, "CQ").End(xlUp)).Find("*,*", A)
- Loop Until A Is Nothing
- End If
- i = 0
- .Select
- For Each A In .Range(.[F2], .Cells(.Rows.Count, "F").End(xlUp))
- A.Offset(, -5).Resize(, 2) = Upw(CStr(A)) '填寫帳密
- r = A.Row
- For Each B In .Range(.Cells(r, "H"), .Cells(r, "CQ"))
- If B = "" Then '找到空格
- ay = dic(Split(B.Address, "$")(1))
- If Not IsEmpty(ay) Then '該儲存格有被公式引用
- For i = 0 To UBound(ay)
- If .Range(ay(i) & r) <> "" Then '引用的參照非空白才計入陣列
- ReDim Preserve Ar(j)
- Ar(j) = Range(ay(i) & r).Value
- j = j + 1
- End If
- Next
- If j > 0 Then B.Value = Application.Round(Application.WorksheetFunction.Average(Ar), 0)
- Erase Ar
- j = 0
- End If
- End If
- Next
- Next
- End With
- Cells.Select
- Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
- "=(COUNTBLANK($A1:$CQ1)>0)*(COUNTA($A1:$CQ1)>0)"
- Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
- With Selection.FormatConditions(1).Interior
- .PatternColorIndex = xlAutomatic
- .ThemeColor = xlThemeColorAccent6
- .TintAndShade = 0.399945066682943
- End With
- Selection.FormatConditions(1).StopIfTrue = True
- End Sub
|
|
發表於 2013-10-29 12:25
| 
