12
返回列表 上一主題 發帖

[發問] 如何利用Sheet1的Q欄顏色當標準，複製當列之C:E的值至Sheet2

棋語鳥鳴

帖子
178 
主題
53 
精華
0 
積分
242 
點名
0  
作業系統
xp 
軟體版本
2007 
閱讀權限
20 
註冊時間
2011-2-22 
最後登錄
2025-4-17 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2011-6-1 20:23 | 只看該作者

[發問] 如何利用Sheet1的Q欄顏色當標準，複製當列之C:E的值至Sheet2

請問如何複製當Sheet1中的Q欄為紫色時，將其當列ㄉc欄到E欄的值複製至Sheet2的A13:C13，第二個的值貼至A14:C14以此類推，將當列Q欄有紫色部分ㄉC:E貼完，參考檔案在附件，請問此類的巨集該如何寫?? TEST.rar (12.06 KB)
收藏 分享

mark15jill
　暱稱: 隨風飄蕩的羽毛
　頭銜: [御用]潛水艇

高中生Rank: 3Rank: 3

帖子
852 
主題
79 
精華
0 
積分
918 
點名
0  
作業系統
Windows 7 , XP 
軟體版本
Office 2007, Office 2003,Office 2010,YoZo Office 
閱讀權限
50 
性別
男 
來自
宇宙 
註冊時間
2011-4-8 
最後登錄
2024-2-21 
2#
發表於 2011-6-2 11:12 | 只看該作者
本帖最後由 mark15jill 於 2011-6-2 11:14 編輯

回復 1# 棋語鳥鳴
若是要以 有紫色 儲存格的列下去做複製的話
    可以用篩選 先將紫色部分區別開來
    作法
     1.紫色那欄位弄個標題 再從 B欄位 到Q欄位 反白後 按篩選
     2.在有紫色的那欄位 選擇 依色彩篩選 然後選紫色
     3.等到全部篩選出來 在複製 選擇要貼上的活頁簿 貼上即可

附檔的代碼
  1.     Sheets("sheet1").Select   '---- 一開始要複製的活頁簿名稱  此行不加的話  有可能錯亂
  2.     Columns("B:Q").Select   '--------   資料範圍 (包含 顏色的Q欄位)
  3.     Selection.AutoFilter
  4.     ActiveSheet.Range("$B$2:$Q$50").AutoFilter Field:=16, Criteria1:=RGB(112, _
  5.         48, 160), Operator:=xlFilterCellColor
  6.     Range("B3:G32").Select
  7.     Selection.Copy
  8.     Sheets("Sheet4").Select  '-----  要貼上的活頁簿名稱
  9.     Range("G13").Select    '---- 要貼上的最左上角儲存格位置
  10.     ActiveSheet.Paste
  11.     ActiveWindow.SmallScroll Down:=6
  12.     Sheets("Sheet1").Select
  13.     Range("F4").Select
  14.     Application.CutCopyMode = False
  15.     Selection.AutoFilter
複製代碼
附檔內 已經有將其弄成巨集 請試驗看看吧..

TEST-檔案.rar (14.17 KB)

TOP

棋語鳥鳴

帖子
178 
主題
53 
精華
0 
積分
242 
點名
0  
作業系統
xp 
軟體版本
2007 
閱讀權限
20 
註冊時間
2011-2-22 
最後登錄
2025-4-17 
3#
發表於 2011-6-2 20:16 | 只看該作者
回復 2# mark15jill


    試驗結果可以!請問我要如何將此巨集改為!一開啟Sheet2就自動執行!
印象中好像是把開頭改成這個即可==>Private Sub Worksheet_Activate()
但是不知道為什麼會出現錯誤??
還是我打錯了??

TOP

mark15jill
　暱稱: 隨風飄蕩的羽毛
　頭銜: [御用]潛水艇

高中生Rank: 3Rank: 3

帖子
852 
主題
79 
精華
0 
積分
918 
點名
0  
作業系統
Windows 7 , XP 
軟體版本
Office 2007, Office 2003,Office 2010,YoZo Office 
閱讀權限
50 
性別
男 
來自
宇宙 
註冊時間
2011-4-8 
最後登錄
2024-2-21 
4#
發表於 2011-6-3 08:37 | 只看該作者
本帖最後由 mark15jill 於 2011-6-3 10:36 編輯

回復 3# 棋語鳥鳴

已經弄OK了...
但是強烈建議 不要擅改程式碼...不然  嘿嘿嘿嘿嘿嘿(會當掉喔..
這不是我設下的陷阱 而是 擅改的話 會進入死回圈.. 又+上我是寫成 活頁簿活動的狀態 所以..

PS 這個檔案 是可以直接以欄位 下去做篩選 而沒有指定特定的儲存格...
如果要新增 請將 欄位擴充即可...
如 A:P  ->a欄位到 P欄位


有兩種方法可以試驗
1.按鈕 command
2.核選check

代碼如下
  1. '------在sheet1下
  2. Private Sub CheckBox1_Change()
  3. If CheckBox1.Value = True Then
  4.     Columns("A:P").Select
  5.     Selection.AutoFilter
  6.     Range("Q1").Select
  7.     ActiveSheet.Range("$A$1:$P$49").AutoFilter Field:=16, Criteria1:=RGB(112, _
  8.         48, 160), Operator:=xlFilterCellColor
  9.     Columns("A:P").Select
  10.     Range("P1").Activate
  11.     Selection.Copy
  12.     Sheets("Sheet4").Select
  13.     ActiveSheet.Paste
  14.     Sheets("Sheet1").Select
  15.     Selection.AutoFilter
  16.     Sheets("Sheet1").Select
  17.    
  18. End If
  19.         CheckBox1.Value = False
  20.     Columns("A:P").Select
  21.     Range("P1").Activate
  22.     Selection.AutoFilter

  24. End Sub


  27. Private Sub CommandButton1_Click()
  28.     Columns("a:p").Select
  29.     Range("p1").Activate
  30.     Selection.AutoFilter
  31.     Range("q1").Select
  32.     ActiveSheet.Range("$B$1:$Q$50").AutoFilter Field:=16, Criteria1:=RGB(112, _
  33.         48, 160), Operator:=xlFilterCellColor
  34.     Columns("a:d").Select
  35.     Selection.Copy
  36.     Sheets("Sheet4").Select
  37.    
  38.     ActiveSheet.Paste
  39.     Sheets("Sheet1").Select
  40.     Columns("p:p").Select
  41.     Application.CutCopyMode = False
  42.     Selection.Copy
  43.     Sheets("Sheet4").Select

  45.     Application.CutCopyMode = False
  46. Sheets("sheet1").Select
  47.     Columns("a:p").Select
  48.     Range("p1").Activate
  49.     Selection.AutoFilter
  50. End Sub
複製代碼
  1. '-sheet4下

  3. Private Sub Worksheet_Activate()
  4. If Range("a1").Value = "編號" Then
  5.         Columns("F:O").Select
  6.     Selection.ClearContents
  7.     Selection.Delete Shift:=xlToLeft
  8.     Range("A1").Select
  9.     End
  10. End If

  12. End Sub
複製代碼
TEST-檔案01.rar (210.62 KB)

TOP

Hsieh

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

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 2011-6-3 08:49 | 只看該作者
回復 3# 棋語鳥鳴
  1. Private Sub Worksheet_Activate()
  2. [A:C] = ""
  3.    With Sheets("sheet1")
  4.     .Columns("B:Q").AutoFilter
  5.     .Range("$B$2").CurrentRegion.AutoFilter Field:=16, Criteria1:=RGB(112, _
  6.         48, 160), Operator:=xlFilterCellColor
  7.    .[C:E].SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible).Copy [A12]
  8.    .Columns("B:Q").AutoFilter
  9.    End With
  10. End Sub
複製代碼
學海無涯_不恥下問

TOP

棋語鳥鳴

帖子
178 
主題
53 
精華
0 
積分
242 
點名
0  
作業系統
xp 
軟體版本
2007 
閱讀權限
20 
註冊時間
2011-2-22 
最後登錄
2025-4-17 
6#
發表於 2011-6-3 22:49 | 只看該作者
回復 5# Hsieh
請問第二行A:C是什麼意思??
如果我不要複製到第二列的A   B  C
想直接從C3開始複製，要如何修改(意思就是不要複製C2:E2)???

TOP

Hsieh

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

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
7#
發表於 2011-6-4 01:13 | 只看該作者
  1. Private Sub Worksheet_Activate()
  2. [A12:C1048576] = "" '清空先前資料
  3.    With Sheets("sheet1")
  4.     .Columns("B:Q").AutoFilter '自動篩選
  5.     .Range("$B$2").CurrentRegion.AutoFilter Field:=16, Criteria1:=RGB(112, _
  6.         48, 160), Operator:=xlFilterCellColor '篩選顏色
  7.    .Range(.[C3], .[C1048576].End(xlUp).Offset(, 2)).SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible).Copy [A13] '複製可見儲存格到A13
  8.    .Columns("B:Q").AutoFilter '取消自動篩選
  9.    End With
  10. End Sub
複製代碼
學海無涯_不恥下問

TOP

棋語鳥鳴

帖子
178 
主題
53 
精華
0 
積分
242 
點名
0  
作業系統
xp 
軟體版本
2007 
閱讀權限
20 
註冊時間
2011-2-22 
最後登錄
2025-4-17 
8#
發表於 2011-6-4 06:42 | 只看該作者
回復 8# Hsieh
A12:C1048576,1048576不知是不是太多，會出現錯誤!我將它改成C100之後即可用
但是:    .Range("$B$2").CurrentRegion.AutoFilter Field:=16, Criteria1:=RGB(112, _
        48, 160), Operator:=xlFilterCellColor '篩選顏色<==這句不知哪裡出了問題!一直出現偵錯(改不好)??

TOP

Hsieh

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

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
9#
發表於 2011-6-4 08:29 | 只看該作者
回復 9# 棋語鳥鳴
2007版本最大列位是1048576沒錯啊，那改成65536試試
如果不是2007以後版本
接下去篩選就不會成立，因為2003版本無法以顏色篩選
若版本正確請將Q欄加上欄名稱
基本上建議EXCEL不要用顏色來統計數值
你的Q欄顏色是用格式化條件而來
應該用條件式來判斷成立與否
學海無涯_不恥下問

TOP

棋語鳥鳴

帖子
178 
主題
53 
精華
0 
積分
242 
點名
0  
作業系統
xp 
軟體版本
2007 
閱讀權限
20 
註冊時間
2011-2-22 
最後登錄
2025-4-17 
10#
發表於 2011-6-4 18:54 | 只看該作者
回復 10# Hsieh


    我是2007版的!不過1048576就是不能??不知是我不是我是用二進位活頁簿的關係!
請問一下為什麼我將這句的.Range(.[C3], .[C1048576].End(xlUp).Offset(, 2)).SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible).Copy [A13]
Range(.[C3], .[C1048576]改成Range(.[C3], .[C47]
為什麼不能到預期的效果，他只複製C2:E2而已，但是將C47改成C100卻能使用??因為在檔案中C48有文字敘述，所以如果用C100會將文字刪掉!，所以能否簡略篩選的範圍??

TOP

        靜思自在 : 人要自愛，才能愛普天下的人。
12
返回列表 上一主題