Board logo

標題: [發問] 如何快速複製剩下沒被選曲的? [打印本頁]
作者: av8d    時間: 2014-3-10 09:41     標題: 如何快速複製剩下沒被選曲的?

A1 B1 C1 D1  分別為  編號  單位  姓名  職稱
資料筆數不定
一般核對資料時都是把我擁有的選取~
找出剩下沒被選取的~

我該如何快速複製這些剩下沒被選曲的呢?
因為經常使用~每次都必須輸寫註記在選取這些沒被選取的~
非常麻煩~請教各位大大了
作者: yen956    時間: 2014-3-11 19:55

回復 1# av8d
是不是這個意思?
  1. Private Sub CommandButton1_Click()
  2.     Dim Rng, rngE As Range, row1 As Integer
  3.     end1 = [A65536].End(xlUp).Row
  4.     Set rngE = [E2].Resize(end1, 1)
  5.     For Each Rng In rngE
  6.         If Rng = "" Then
  7.             Cells(Rng.Row, 1).Resize(1, 4).Copy
  8.             row1 = [I65536].End(xlUp).Offset(1, 0).Row
  9.             Cells(row1, 9).Resize(1, 4).Select
  10.             ActiveSheet.Paste
  11.         End If
  12.     Next
  13. End Sub

  15. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  16.     Dim rngE As Range
  17.     end1 = [A65536].End(xlUp).Row
  18.     Set rngE = [E1].Resize(end1, 1)
  19.     If Not Intersect(Target, rngE) Is Nothing Then
  20.         If Target = "v" Then
  21.             Target = ""
  22.         Else
  23.             Target = "v"
  24.         End If
  25.     End If
  26. End Sub
複製代碼
作者: av8d    時間: 2014-3-12 14:52

回復 2# yen956


    太神啦!
我想詢問一下~如果我想修改成複製選取的~該如何改?
我先研究一下~再次感謝
作者: yen956    時間: 2014-3-12 17:41

本帖最後由 yen956 於 2014-3-12 17:44 編輯

補充說明：
在VBA編輯器中, Double Click 左邊的 "sheet1"...等,
會出現 空白編輯視窗,
按下 空白編輯視窗 正上方的 下拉式選單, 選取 "Worksheet",
右邊的 下拉式選單 中, 選取 "SelectionChange",
就會自動跳出:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
之後你在 "sheet1"... 如有 SelectionChange 的動作,
就會觸動此副程式, 並將 Cell 附予 Target,
例如從 A1 移到 B2, 則 Target=A1, 並對整張 Worksheet 有效,
但 Intersect(Target, rngE) 可將 SelectionChange
的有效範圍限制在 rngE 中,
    If Not Intersect(Target, rngE) Is Nothing Then
    End If
Not Intersect(Target, rngE) Is Nothing→負負得正
→表示 Target 並非 Nothing.
作者: yen956    時間: 2014-3-12 17:42

回復 3# av8d
大大你好, 什麼叫【複製選取】?
可不可以舉例(或附檔)說明.
作者: yen956    時間: 2014-3-12 23:17

回復 4# yen956
對不起, 弄錯了!!
錯誤:
例如從 A1 移到 B2, 則 Target=A1, 並對整張 Worksheet 有效,
更正:
例如從 A1 移到 B2, 則 Target=B2, 並對整張 Worksheet 有效,
作者: av8d    時間: 2014-3-14 10:13

本帖最後由 av8d 於 2014-3-14 10:27 編輯

回復 5# yen956


    956大大~真不好意思~最近比較忙那麼晚才回覆您~
我把疑問一一列出

1.非打勾的複製~改成打勾的複製~該如何改寫
測試OK
If Rng = "v" Then

2.如果要複製到J到M欄~該如何寫
3.如果要複製到Sheet3~該如何寫
4.如果E欄改成F欄~該如何改寫
5.如果只要複製B和D欄~該如何改寫

6.如果只要複製B到D欄~該如何改寫
測試OK
Cells(Rng.Row, 2).Resize(1, 4).Copy

如果方便的話可否解說關於Private Sub CommandButton1_Click()內容~謝謝
作者: av8d    時間: 2014-3-14 11:28

回復 7# av8d


    剩下問題3
要複製到Sheet3的B2
作者: yen956    時間: 2014-3-14 13:07

回復 8# av8d
試試看:
Private Sub CommandButton1_Click()
    Dim Rng, rngE As Range, row1, i As Integer
   
    Dim sh1, sh3 As Object
'   Set sh1 = ThisWorkbook.Sheets("Sheet1")
    Set sh3 = ThisWorkbook.Sheets("Sheet3")
   
    end1 = [A65536].End(xlUp).Row
    Set rngE = [E2].Resize(end1, 1)
    i = 2
    sh3.Activate
    For Each Rng In rngE
        If Rng = "v" Then
            Cells(Rng.Row, 1).Resize(1, 4).Copy
            sh3.Cells(i, 2).Select
'            row1 = [I65536].End(xlUp).Offset(1, 0).Row
'            Cells(row1, 9).Resize(1, 4).Select
            ActiveSheet.Paste
            i = i + 1
        End If
    Next
End Sub
作者: av8d    時間: 2014-3-14 18:03

回復 9# yen956


    大大~謝謝你~太厲害了~

我想再問一個問題~這問題沒解開沒關係~
因為有點複雜~有些難度~
問題一：
如果要複製到右邊又要複製到Sheet3兩種都要有該如何做呢?

問題二(進階題)：
如果
把打勾的地方改成
原本A,B,C,D,打勾
改成A,B,打勾,C,D
位置更動，這樣似乎會比較方便使用者~但是會讓變得不好寫~

再次麻煩大大~謝謝
作者: yen956    時間: 2014-3-15 13:37

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

本帖最後由 av8d 於 2014-3-15 21:09 編輯
  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    時間: 2014-3-16 09:58

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

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

也就是將
    Set rngE = [E1].Resize(end1, 1)
改成
    Set rngE = [C1].Resize(end1, 1)
就可以了
作者: Hsieh    時間: 2014-3-16 23:04

回復 10# av8d
[attach]17780[/attach]
  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

  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

  29. End Sub

  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
複製代碼
[attach]17781[/attach]
作者: av8d    時間: 2014-3-17 19:36

本帖最後由 av8d 於 2014-3-17 19:40 編輯

回復 14# Hsieh

我嘗試修改了一下程式~可能是我還沒理解~
所以還無法改出我希望的答案~能否有勞大大代為修改了
    希望答案是這樣~如下
[attach]17792[/attach]

觸發打勾的只要C,D欄就好~其餘的欄位希望可以不要觸發~謝謝
作者: av8d    時間: 2014-3-17 19:53

回復 13# yen956


    請問能否只按下一個按鈕可以同時完成?如下
[attach]17795[/attach]

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

可能有點難度~不過還是很感謝大大的幫忙
作者: Hsieh    時間: 2014-3-17 23:11

回復 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    時間: 2014-3-18 08:56

回復 17# Hsieh


    非常感謝Hsieh大大和yen956大大的大力幫助
受益良多~讓我的問題都迎刃而解~再次感謝！
作者: yen956    時間: 2014-3-18 15:17

回復 17# Hsieh
還好有大大的幫忙, 不然真會被考倒, 收下啦, 謝謝!!
作者: av8d    時間: 2014-3-21 11:01

本帖最後由 av8d 於 2014-3-21 11:12 編輯

回復 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老師
作者: Hsieh    時間: 2014-3-21 11:12

回復 20# av8d
全選甚麼位置?
例如C欄全選
[C:C].Select
因為你有工作表事件程序Selection_Change
所以避免觸發程序
Application.EnableEvents = False
[C:C].Select
Application.EnableEvents = True
作者: av8d    時間: 2014-3-21 11:30

回復 21# Hsieh


   我按全部刪除~然後點複製沒勾選的~就OK了~
我剛測試了一下H老師的~似乎沒反應~
暫時用複製沒勾選的~謝謝老師



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