123
返回列表 上一主題 發帖

[發問] 如何快速複製剩下沒被選曲的?

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
11# 跳轉到 »
發表於 2014-3-15 13:37 | 只看該作者
問題一：
如果要複製到右邊又要複製到Sheet3兩種都要有該如何做呢?
不是兩個程序合併起來就好了嗎?
﹝執行﹞複製到右邊
﹝執行﹞複製到Sheet3
問題二(進階題)：
把打勾的地方改成
原本A,B,C,D,打勾
改成A,B,打勾,C,D位置更動，
C,D位置更動  要改到那裡?

TOP

av8d

帖子
703 
主題
276 
精華
0 
積分
1005 
點名
1  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2011-6-30 
最後登錄
2024-5-29 
12#
發表於 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留給打勾的

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
13#
發表於 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)
就可以了

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
257  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-27 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
14#
發表於 2014-3-16 23:04 | 只看該作者
回復 10# av8d
play.gif
  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
複製代碼
反選.zip (21.77 KB)
學海無涯_不恥下問

TOP

av8d

帖子
703 
主題
276 
精華
0 
積分
1005 
點名
1  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2011-6-30 
最後登錄
2024-5-29 
15#
發表於 2014-3-17 19:36 | 只看該作者
本帖最後由 av8d 於 2014-3-17 19:40 編輯

回復 14# Hsieh

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

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

TOP

av8d

帖子
703 
主題
276 
精華
0 
積分
1005 
點名
1  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2011-6-30 
最後登錄
2024-5-29 
16#
發表於 2014-3-17 19:53 | 只看該作者
回復 13# yen956


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

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

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

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
257  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-27 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
17#
發表於 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
學海無涯_不恥下問

TOP

av8d

帖子
703 
主題
276 
精華
0 
積分
1005 
點名
1  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2011-6-30 
最後登錄
2024-5-29 
18#
發表於 2014-3-18 08:56 | 只看該作者
回復 17# Hsieh


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

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
19#
發表於 2014-3-18 15:17 | 只看該作者
回復 17# Hsieh
還好有大大的幫忙, 不然真會被考倒, 收下啦, 謝謝!!

TOP

av8d

帖子
703 
主題
276 
精華
0 
積分
1005 
點名
1  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2011-6-30 
最後登錄
2024-5-29 
20#
發表於 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老師

TOP

        靜思自在 : 君子立恆志，小人恆立志。
123
返回列表 上一主題