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

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

2^#

發表於 2014-3-11 19:55 | 只看該作者

回復 1# av8d
是不是這個意思?

Private Sub CommandButton1_Click()
Dim Rng, rngE As Range, row1 As Integer
end1 = [A65536].End(xlUp).Row
Set rngE = [E2].Resize(end1, 1)
For Each Rng In rngE
If Rng = "" Then
Cells(Rng.Row, 1).Resize(1, 4).Copy
row1 = [I65536].End(xlUp).Offset(1, 0).Row
Cells(row1, 9).Resize(1, 4).Select
ActiveSheet.Paste
End If
Next
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rngE As Range
end1 = [A65536].End(xlUp).Row
Set rngE = [E1].Resize(end1, 1)
If Not Intersect(Target, rngE) Is Nothing Then
If Target = "v" Then
Target = ""
Else
Target = "v"
End If
End If
End Sub

複製代碼

av8d

帖子: 703
主題: 276
精華: 0
積分: 1005
點名: 1
作業系統: Windows 10
軟體版本: Office 2019
閱讀權限: 50
性別: 男
註冊時間: 2011-6-30
最後登錄: 2024-5-29

3^#

發表於 2014-3-12 14:52 | 只看該作者

回復 2# yen956

太神啦!
我想詢問一下~如果我想修改成複製選取的~該如何改?
我先研究一下~再次感謝

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

4^#

發表於 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.

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

5^#

發表於 2014-3-12 17:42 | 只看該作者

回復 3# av8d
大大你好, 什麼叫【複製選取】?
可不可以舉例(或附檔)說明.

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

6^#

發表於 2014-3-12 23:17 | 只看該作者

回復 4# yen956
對不起, 弄錯了!!
錯誤:
例如從 A1 移到 B2, 則 Target=A1, 並對整張 Worksheet 有效,
更正:
例如從 A1 移到 B2, 則 Target=B2, 並對整張 Worksheet 有效,

av8d

帖子: 703
主題: 276
精華: 0
積分: 1005
點名: 1
作業系統: Windows 10
軟體版本: Office 2019
閱讀權限: 50
性別: 男
註冊時間: 2011-6-30
最後登錄: 2024-5-29

7^#

發表於 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

帖子: 703
主題: 276
精華: 0
積分: 1005
點名: 1
作業系統: Windows 10
軟體版本: Office 2019
閱讀權限: 50
性別: 男
註冊時間: 2011-6-30
最後登錄: 2024-5-29

8^#

發表於 2014-3-14 11:28 | 只看該作者

回復 7# av8d

剩下問題3
要複製到Sheet3的B2

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

9^#

發表於 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

帖子: 703
主題: 276
精華: 0
積分: 1005
點名: 1
作業系統: Windows 10
軟體版本: Office 2019
閱讀權限: 50
性別: 男
註冊時間: 2011-6-30
最後登錄: 2024-5-29

10^#

發表於 2014-3-14 18:03 | 只看該作者

回復 9# yen956

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

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

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

再次麻煩大大~謝謝