- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 43
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2025-2-19
               
|
8#
發表於 2012-2-3 09:13
| 只看該作者
回復 7# tonycho33
Sheet1模組- Private Sub Worksheet_SelectionChange(ByVal Target As Range)
- Set Rng = Range("B2:E2,B5:E5,B10:E10")
- Rng.Interior.ColorIndex = xlNone
- Rng.Font.ColorIndex = xlAutomatic
- If Not Intersect(Rng, Target) Is Nothing Then
- Set a = Sheet2.[A:B].Find(Target, lookat:=xlWhole)
- If Not a Is Nothing Then
- k = 3 - a.Column
- Ar = a.Offset(, k).Resize(, 5).Value
- With UserForm1
- .Show 0
- '因為TEXTBOX並未依序排列所以必須一一給值
- .TextBox27 = Ar(1, 4)
- .TextBox28 = Ar(1, 5)
- .TextBox29 = Ar(1, 3)
- .TextBox30 = Ar(1, 2)
- .TextBox31 = Ar(1, 1)
- End With
- End If
- End If
- End Sub
- Sub Ex()
- Dim Ob As Shape, Ar(), Rng As Range
- Set Ob = Sheet1.Shapes(Application.Caller)
- Set Rng = Sheet1.Range("B2:E2,B5:E5,B10:E10")
- Rng.Interior.ColorIndex = xlNone
- Rng.Font.ColorIndex = xlAutomatic
- a = Asc(Ob.TextFrame.Characters.Text) + 2
- b = Sheet1.Cells(Ob.TopLeftCell.Row, "L").Value
- With Sheet2
- For Each c In .Range(Chr(a) & 1).EntireColumn.SpecialCells(xlCellTypeConstants)
- If c < b Then
- For i = 1 To 2
- If .Cells(c.Row, i) <> "" Then
- ReDim Preserve Ar(s)
- Ar(s) = .Cells(c.Row, i)
- s = s + 1
- End If
- Next
- End If
- Next
- End With
- If s > 0 Then
- For Each d In Ar
- With Rng.Find(d, lookat:=xlWhole)
- .Interior.ColorIndex = 3
- .Font.ColorIndex = 2
- End With
- Next
- End If
- End Sub
|
|
發表於 2012-2-1 14:31
| 
