麻辣家族討論版版 - Powered by Discuz! Board

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

複製代碼