sheau-lan

中學生 Rank: 2

帖子: 96
主題: 24
精華: 0
積分: 149
點名: 0
作業系統: WINDOWES
軟體版本: OFFICE
閱讀權限: 20
性別: 女
註冊時間: 2011-10-11
最後登錄: 2018-9-25

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2012-12-26 20:58 | 只看該作者

想請各位大大幫忙VBA

VBA程式應該怎麼寫

請教.rar (49.8 KB)

顏色改變

樓主熱帖

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2012-12-27 07:39 | 只看該作者

本帖最後由 GBKEE 於 2012-12-27 20:35 編輯

回復 1# sheau-lan
工作表所有的預設事件程序: 可編寫程式碼為你期望的效果
Worksheet_BeforeDouble 是工作表在儲存格: 左鍵連按二次的預設事件程序
在Sheet1任一有資料的儲存格,左鍵連按二次的程式碼
程式碼需複製在這工作表的模組裡

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Rng As Range
If Target = "" Then Exit Sub '空白的儲存格:離開程序
Cells(Target.Row, 1).Resize(, 3).Interior.ColorIndex = xlNone '設定為無底色
If Not Application.Intersect(Target, UsedRange.Offset(1)) Is Nothing Then
'Intersect 方法傳回 Range 物件，此物件代表兩個或多個範圍重疊的矩形範圍。
Set Rng = Sheets("Sheet2").Range("A:A").Find(Cells(Target.Row, "A"), Lookat:=xlWhole) 'Sheet2的A欄中尋找
'Cells(Target.Row, "A" ): '作用儲存格的A欄
If Not Rng Is Nothing Then '尋找到
If Application.Phonetic(Rng.Resize(, 3)) = Application.Phonetic(Cells(Target.Row, "A").Resize(, 3)) Then '比對字串
Cells(Target.Row, "A").Resize(, 3).Interior.Color = vbYellow '黃色
End If
End If
End If
End Sub

複製代碼

TOP

sheau-lan

中學生 Rank: 2

帖子: 96
主題: 24
精華: 0
積分: 149
點名: 0
作業系統: WINDOWES
軟體版本: OFFICE
閱讀權限: 20
性別: 女
註冊時間: 2011-10-11
最後登錄: 2018-9-25

3^#

發表於 2012-12-27 19:29 | 只看該作者

奇怪喔...它都會出現無法指定至陣列ㄟ

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2012-12-27 20:37 | 只看該作者

回復 4# sheau-lan
2# 已修正
03 Dim Rng( 1 to 2 ) As Range ->修改 Dim Rng As Range

TOP

sheau-lan

中學生 Rank: 2

帖子: 96
主題: 24
精華: 0
積分: 149
點名: 0
作業系統: WINDOWES
軟體版本: OFFICE
閱讀權限: 20
性別: 女
註冊時間: 2011-10-11
最後登錄: 2018-9-25

5^#

發表於 2012-12-28 21:24 | 只看該作者

GBKEE 大.這樣跟我想的好像有一點不太一樣
我要的跟"[發問]篩選?關鍵字?查詢?"
這一個的內容很像.不過它從sheet1按2下複製過sheet2時sheet1的資料不會變顏色
可是我是想要複製過就直接變顏色.而不是需要自己先複製到sheet2再回來sheet1點擊資料讓它變顏色
請在幫忙..謝謝...麻煩了.

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

6^#

發表於 2012-12-29 11:43 | 只看該作者

回復 5# sheau-lan

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim R As Range, Msg As Boolean
If Target = "" Then Exit Sub '空白的儲存格:離開程序
If Not Application.Intersect(Target, UsedRange.Offset(1)) Is Nothing Then
'Intersect 方法傳回 Range 物件，此物件代表兩個或多個範圍重疊的矩形範圍。
With Sheets("Sheet2").UsedRange.Columns(1) 'UsedRange :工作表中的已用範圍->避免"比對字串"到工作表底部
For Each R In .Cells
If Application.Phonetic(R.Resize(, 3)) = Application.Phonetic(Cells(Target.Row, "A").Resize(, 3)) Then
'比對字串
Msg = True
End If
Next
If Msg = False Then
.Cells(.Cells.Count + 1).Resize(, 3) = Cells(Target.Row, "A").Resize(, 3).Value '複製資料到Sheets("Sheet2")
Cells(Target.Row, "A").Resize(, 3).Interior.Color = vbYellow '黃色
End If
End With
End If
End Sub

複製代碼

TOP

sheau-lan

中學生 Rank: 2

帖子: 96
主題: 24
精華: 0
積分: 149
點名: 0
作業系統: WINDOWES
軟體版本: OFFICE
閱讀權限: 20
性別: 女
註冊時間: 2011-10-11
最後登錄: 2018-9-25

7^#

發表於 2012-12-30 14:26 | 只看該作者

恩...謝謝大大..這真可讓我研究好幾天囉!!
實在太感謝囉!!

TOP