想請各位大大幫忙VBA

sheau-lan

VBA程式應該怎麼寫

GBKEE

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

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

複製代碼

sheau-lan

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

GBKEE

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

sheau-lan

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

GBKEE

回復 5# sheau-lan

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

複製代碼

sheau-lan

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