返回列表 上一主題 發帖

請問儲存格自訂表單功能

回復 3# tonycho33

是否如附件效果
儲存格自訂表單.rar (19.18 KB)
學海無涯_不恥下問

TOP

回復 5# tonycho33

如葛是搜尋2欄的資料
那就再增加判斷在哪一欄搜尋到
才能正確指出C欄以後的資料
學海無涯_不恥下問

TOP

回復 7# tonycho33

Sheet1模組
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2. Set Rng = Range("B2:E2,B5:E5,B10:E10")
  3. Rng.Interior.ColorIndex = xlNone
  4. Rng.Font.ColorIndex = xlAutomatic
  5.     If Not Intersect(Rng, Target) Is Nothing Then
  6.     Set a = Sheet2.[A:B].Find(Target, lookat:=xlWhole)
  7.     If Not a Is Nothing Then
  8.    k = 3 - a.Column
  9.     Ar = a.Offset(, k).Resize(, 5).Value
  10.         With UserForm1
  11.     .Show 0
  12.     '因為TEXTBOX並未依序排列所以必須一一給值
  13.     .TextBox27 = Ar(1, 4)
  14.     .TextBox28 = Ar(1, 5)
  15.     .TextBox29 = Ar(1, 3)
  16.     .TextBox30 = Ar(1, 2)
  17.     .TextBox31 = Ar(1, 1)
  18.     End With
  19.     End If
  20.     End If
  21. End Sub
複製代碼
一般模組
  1. Sub Ex()
  2. Dim Ob As Shape, Ar(), Rng As Range
  3. Set Ob = Sheet1.Shapes(Application.Caller)
  4. Set Rng = Sheet1.Range("B2:E2,B5:E5,B10:E10")
  5. Rng.Interior.ColorIndex = xlNone
  6. Rng.Font.ColorIndex = xlAutomatic
  7. a = Asc(Ob.TextFrame.Characters.Text) + 2
  8. b = Sheet1.Cells(Ob.TopLeftCell.Row, "L").Value
  9. With Sheet2
  10. For Each c In .Range(Chr(a) & 1).EntireColumn.SpecialCells(xlCellTypeConstants)
  11. If c < b Then
  12. For i = 1 To 2
  13. If .Cells(c.Row, i) <> "" Then
  14. ReDim Preserve Ar(s)
  15. Ar(s) = .Cells(c.Row, i)
  16. s = s + 1
  17. End If
  18. Next
  19. End If
  20. Next
  21. End With
  22. If s > 0 Then
  23. For Each d In Ar
  24.   With Rng.Find(d, lookat:=xlWhole)
  25.   .Interior.ColorIndex = 3
  26.   .Font.ColorIndex = 2
  27.   End With
  28. Next
  29. End If
  30. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 【蒙蔽的自由】人常在什麼都可以自由自在的時候,卻被這種隨心所欲的自由蒙蔽,虛擲時光而毫無覺知。
返回列表 上一主題