- 帖子
- 522
- 主題
- 36
- 精華
- 1
- 積分
- 603
- 點名
- 0
- 作業系統
- win xp sp3
- 軟體版本
- Office 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-12-13
- 最後登錄
- 2021-7-11
|
26#
發表於 2015-11-23 19:02
| 只看該作者
連續兩次都貼錯地方, 實在不可原諒!!
想貼的是這個!!
試試看!!
sheet1(設備列表)的VBA Code如下:- Option Explicit
- Private Sub Worksheet_Change(ByVal Target As Range)
- Dim rngA As Range, rngB As Range, foundCel As Range
- Dim lastRow As Long
- If Target.Count > 1 Then Exit Sub '如果一次Change太多格就離開
- lastRow = Sheets("公司清單").Cells(Rows.Count, 2).End(xlUp).Row
- Set rngA = Sheets("公司清單").Range("B2:B" & lastRow & "") '設定 "公司清單" 的範圍給 rngA
- lastRow = Cells(Rows.Count, 2).End(xlUp).Row
- Set rngB = Range("B2:B" & lastRow & "") '設定 "設備列表" 的範圍給 rngB
- If Not Intersect(Target, rngB) Is Nothing Then
- Set foundCel = rngA.Find(Target, lookat:=xlWhole) 'rngA 中尋找 Target
- If Not foundCel Is Nothing Then '有找到
- Target.Offset(0, -1).Resize(1, 11).Interior.ColorIndex = _
- foundCel.Offset(0, 1).Interior.ColorIndex
- ' Else
- '建議 "設備列表" 的 "使用公司" 用 驗證清單 輸入
- '則此處就不必檢查輸入是否有錯誤, 換言之, 就沒有 Else 這一段
- '又 驗證清單 字體很小又不能改, 不適合弱視者,
- '建議 "設備列表" 整頁全部改用小字體, 再放大檢視比例
- End If
- End If
- End Sub
- Option Explicit
- Public colorNum As Integer
- '先執行此VBA一次, 以建立代碼表
- Sub 顏色代碼表()
- Dim i As Integer
- For i = 1 To 28
- Cells(i, 15).Interior.ColorIndex = i
- Cells(i, 16).Interior.ColorIndex = i + 28
- Next
- End Sub
- '作用：用以編輯"公司清單"C欄的儲存格顏色
- Private Sub Worksheet_SelectionChange(ByVal Target As Range)
- Dim rng As Range
- If Target.Count > 1 Then Exit Sub
- Set rng = Application.Union([C:C], [O1:P28])
- If Intersect(Target, rng) Is Nothing Then Exit Sub
- If Target.Column = 3 Then
- Target.Interior.ColorIndex = colorNum
- Else
- colorNum = Target.Interior.ColorIndex
- End If
- End Sub
 測試檔案.rar (381.48 KB)
|
|
