yen956

問題一：
如果要複製到右邊又要複製到Sheet3兩種都要有該如何做呢?
不是兩個程序合併起來就好了嗎?
﹝執行﹞複製到右邊
﹝執行﹞複製到Sheet3
問題二(進階題)：
把打勾的地方改成
原本A,B,C,D,打勾
改成A,B,打勾,C,D位置更動，
C,D位置更動  要改到那裡?

av8d

1. Private Sub CommandButton1_Click()
   
2.     Dim Rng, rngE As Range, row1, i As Integer
   
3.    
   
4.     Dim sh1, sh3 As Object
   
5. '   Set sh1 = ThisWorkbook.Sheets("Sheet1")
   
6.     Set sh3 = ThisWorkbook.Sheets("工作表3")
   
7.    
   
8.     end1 = [A65536].End(xlUp).Row
   
9.     Set rngE = [E2].Resize(end1, 1)
   
10.     i = 2
    
11.     For Each Rng In rngE
    
12.         If Rng = "v" Then
    
13.             Cells(Rng.Row, 1).Resize(1, 4).Copy
    
14.             row1 = [I65536].End(xlUp).Offset(1, 0).Row
    
15.             Cells(row1, 9).Resize(1, 4).Select
    
16.             ActiveSheet.Paste
    
17.         End If
    
18.         sh3.Activate
    
19.         If Rng = "v" Then
    
20.             Cells(Rng.Row, 1).Resize(1, 4).Copy
    
21.             sh3.Cells(i, 2).Select
    
22.             ActiveSheet.Paste
    
23.             i = i + 1
    
24.         End If
    
25.     Next
    
26. End Sub

複製代碼

結合後變成這樣?但是會出現錯誤

    更動到旁邊 D E
C留給打勾的

yen956

更動到旁邊 D E, C留給打勾的
本來 欄E 用來打勾,
插入 欄C, 變成 欄C 用來打勾, 其餘向右移?

改變 Worksheet_SelectionChange 的 觸動對像 就可以了,
詳見 4f及6f 的說明

也就是將
    Set rngE = [E1].Resize(end1, 1)
改成
    Set rngE = [C1].Resize(end1, 1)
就可以了

Hsieh

回復 10# av8d

下載 (63.83 KB)

2014-3-16 23:02

1. Private Sub CommandButton1_Click() '反選
   
2. Application.EnableEvents = False
   
3. Dim Rng As Range
   
4. For Each a In Range("C:C").SpecialCells(xlCellTypeBlanks)
   
5. If Rng Is Nothing Then
   
6.   Set Rng = Union(Cells(a.Row, "B"), Cells(a.Row, "D"))
   
7.   Else
   
8.   Set Rng = Union(Rng, Union(Cells(a.Row, "B"), Cells(a.Row, "D")))
   
9. End If
   
10. Next
    
11. Rng.Copy [J1]
    
12. Rng.Copy Sheets(3).[B2]
    
13. Application.EnableEvents = True
    
14. End Sub
    
15. 
    
16. Private Sub CommandButton2_Click() '選取
    
17. Application.EnableEvents = False
    
18. Dim Rng As Range
    
19. Set Rng = Union([B1], [D1])
    
20. For Each a In Range("C:C").SpecialCells(xlCellTypeConstants)
    
21.   Set Rng = Union(Rng, Union(Cells(a.Row, "B"), Cells(a.Row, "D")))
    
22. Next
    
23. Range("J1").CurrentRegion.Clear
    
24. Rng.Copy [J1]
    
25. Sheets(3).[B2].CurrentRegion.Clear
    
26. Rng.Copy Sheets(3).[B2]
    
27. Application.EnableEvents = True
    
28. 
    
29. End Sub
    
30. 
    
31. Private Sub Worksheet_SelectionChange(ByVal Target As Range) '打勾
    
32. If Cells(Target.Row, 1) <> "" Then Cells(Target.Row, 3) = IIf(Cells(Target.Row, 3) = "", "v", "")
    
33. End Sub

複製代碼

反選.zip (21.77 KB)

下載次數: 7

2014-3-16 23:04

av8d

回復 14# Hsieh

我嘗試修改了一下程式~可能是我還沒理解~
所以還無法改出我希望的答案~能否有勞大大代為修改了
    希望答案是這樣~如下
正反.rar (20.51 KB)

下載次數: 2

2014-3-17 19:38

觸發打勾的只要C,D欄就好~其餘的欄位希望可以不要觸發~謝謝

av8d

回復 13# yen956


    請問能否只按下一個按鈕可以同時完成?如下
單按鈕.rar (21.41 KB)

下載次數: 2

2014-3-17 19:52

因為工作表2的大毛和三毛被打勾
按下按鈕後~產生了J1:M3
同時也產生了工作表1的B2:D3

可能有點難度~不過還是很感謝大大的幫忙

Hsieh

回復 15# av8d
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '打勾
If Cells(Target.Row, 1) <> "" And Target.Column = 3 Or Target.Column = 4 Then Cells(Target.Row, 3) = IIf(Cells(Target.Row, 3) = "", "v", "")
End Sub

av8d

回復 17# Hsieh


    非常感謝Hsieh大大和yen956大大的大力幫助
受益良多~讓我的問題都迎刃而解~再次感謝！

yen956

回復 17# Hsieh
還好有大大的幫忙, 不然真會被考倒, 收下啦, 謝謝!!

av8d

回復 17# Hsieh


    請教H老師~
我將您的稍微改了一下

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range) '打勾
   
2. If Cells(Target.Row, 1) <> "" And Target.Column = 3 Or Target.Column = 5 Then Cells(Target.Row, 5) = IIf(Cells(Target.Row, 5) = "", "v", "")
   
3. End Sub

複製代碼

請問我製作了一個按鈕~想讓他按下去後~全選或全刪
是否有辦法?再次感謝

-------------------------------------------------------------------
全刪我大概想到了~就是直接指定刪除一整行~
全選大概想到的方法就是負制沒打勾的
再次感謝H老師