- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 88
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2024-4-16
              
|
17#
發表於 2012-12-19 01:01
| 只看該作者
回復 16# cmo140497
不知道理解是否正確
將文字檔與程式檔至於同一資料夾試試
 RawData.rar (26.7 KB)
- Sub InputData()
- Dim Btn(), Mystr$, ARng As Range
- fd = ThisWorkbook.Path & "\"
- fs = Dir(fd & "*.txt")
- With ActiveSheet
- .CheckBoxes.Delete
- .Cells.Clear
- Do Until fs = ""
- Open fd & fs For Input As #1
- Do While Not EOF(1)
- Line Input #1, Mystr
- If InStr(Mystr, ":") > 0 Then
- r = r + 1
- .Cells(r, 3) = Split(Mystr, ":")(0)
- If InStr(Split(Mystr, ":")(1), " ") > 0 Then
- ar = Split(Split(Mystr, ":")(1), " ")
- .Cells(r, 5).Resize(, UBound(ar) + 1) = ar
- Else
- .Cells(r, 5) = Replace(Split(Mystr, ":")(1), "ITEM", "")
- ReDim Preserve Btn(s)
- Btn(s) = Replace(Split(Mystr, ":")(1), "ITEM", "")
- s = s + 1
- End If
- End If
- Loop
- Close #1
- r = r + 1
- fs = Dir
- Loop
- .Cells(r, 5).Resize(, UBound(ar) + 1).EntireColumn.AutoFit
- For i = 0 To s - 1
- With .CheckBoxes.Add(.Cells(i + 4, "A").Left, .Cells(i + 4, "A").Top, .Cells(i + 4, "A").Width, .Cells(i + 4, "A").Height)
- .Characters.Text = Btn(i)
- .OnAction = "Get_Rng"
- End With
- Next
- .Range(.Range(.[E2], .[E2].End(xlDown)), .Range(.[E2], .[E2].End(xlDown)).End(xlToRight)).Copy .[AI2]
- .[AI2].CurrentRegion.EntireColumn.AutoFit
- Set ARng = .[AI2].CurrentRegion
- ARng.Replace "___", ""
- ARng.SpecialCells(xlCellTypeConstants).Value = 0
- ARng.SpecialCells(xlCellTypeBlanks).Value = "___"
- End With
- ActiveWindow.Zoom = 75
- End Sub
- Sub Get_Rng()
- Dim A As Range, Rng As Range, Sp As Shape, CRng As Range
- With ActiveSheet
- For Each Sp In .Shapes
- If Sp.Name Like "Check Box*" Then
- If Sp.OLEFormat.Object.Value = 1 Then
- n = Sp.OLEFormat.Object.Caption
- Set A = .Columns("E").Find(n, lookat:=xlWhole)
- If Rng Is Nothing Then
- Set Rng = A.CurrentRegion
- Else
- Set Rng = Union(Rng, A.CurrentRegion)
- End If
- End If
- End If
- Next
- If Rng Is Nothing Then
- MsgBox "Nothing"
- Else
- For x = 1 To Rng.Areas(1).Columns.Count
- For y = 2 To Rng.Areas(1).Rows.Count
- ReDim ay(1 To Rng.Areas.Count)
- ReDim ary(1 To Rng.Areas.Count)
- For i = 1 To Rng.Areas.Count
- If Rng.Areas(i).Cells(y, x) = "000" Then .[AI2].CurrentRegion.Cells(y - 1, x).Interior.ColorIndex = 4: GoTo 10
- ay(i) = Rng.Areas(i).Cells(y, x)
- Next
- For j = 1 To UBound(ay)
- For s = 1 To UBound(ay)
- If ay(j) = ay(s) Then cnt = cnt + 1
- Next
- ary(j) = cnt: cnt = 0
- Next
- g = Application.Lookup(Application.Max(ary) / Rng.Areas.Count, Array(0, 0.19, 0.39, 0.59, 0.79, 0.99, 1), Array(4, 44, 8, 6, 7, 3, 16))
- With .[AI2].CurrentRegion.Cells(y - 1, x)
- If .Value = "___" Then
- .Interior.ColorIndex = -4142
- Else
- .Interior.ColorIndex = g
- End If
- End With
- 10
- Next
- Next
- End If
- End With
- End Sub
|
|
發表於 2012-12-17 16:41
| 
