Board logo

標題: 想請各位大大幫忙VBA [打印本頁]
作者: sheau-lan    時間: 2012-12-26 20:58     標題: 想請各位大大幫忙VBA

VBA程式應該怎麼寫
作者: GBKEE    時間: 2012-12-27 07:39

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

回復 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    時間: 2012-12-27 19:29

奇怪喔...它都會出現無法指定至陣列ㄟ
作者: GBKEE    時間: 2012-12-27 20:37

回復 4# sheau-lan
2#  已修正  
03  Dim Rng( 1 to 2 )  As Range ->修改    Dim Rng As Range
作者: sheau-lan    時間: 2012-12-28 21:24

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

回復 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    時間: 2012-12-30 14:26

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)