麻辣家族討論版版 - Powered by Discuz! Board

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

作者: 棋語鳥鳴 時間: 2011-6-1 20:23 標題: 如何利用Sheet1的Q欄顏色當標準，複製當列之C:E的值至Sheet2

請問如何複製當Sheet1中的Q欄為紫色時，將其當列ㄉc欄到E欄的值複製至Sheet2的A13:C13，第二個的值貼至A14:C14以此類推，將當列Q欄有紫色部分ㄉC:E貼完，參考檔案在附件，請問此類的巨集該如何寫??[attach]6454[/attach]

作者: mark15jill 時間: 2011-6-2 11:12

本帖最後由 mark15jill 於 2011-6-2 11:14 編輯

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

附檔的代碼

Sheets("sheet1").Select '---- 一開始要複製的活頁簿名稱此行不加的話有可能錯亂
Columns("B:Q").Select '-------- 資料範圍 (包含顏色的Q欄位)
Selection.AutoFilter
ActiveSheet.Range("$B$2:$Q$50").AutoFilter Field:=16, Criteria1:=RGB(112, _
48, 160), Operator:=xlFilterCellColor
Range("B3:G32").Select
Selection.Copy
Sheets("Sheet4").Select '----- 要貼上的活頁簿名稱
Range("G13").Select '---- 要貼上的最左上角儲存格位置
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=6
Sheets("Sheet1").Select
Range("F4").Select
Application.CutCopyMode = False
Selection.AutoFilter

複製代碼

附檔內已經有將其弄成巨集請試驗看看吧..

[attach]6459[/attach]

作者: 棋語鳥鳴 時間: 2011-6-2 20:16

回復 2# mark15jill

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

作者: mark15jill 時間: 2011-6-3 08:37

本帖最後由 mark15jill 於 2011-6-3 10:36 編輯

回復 3# 棋語鳥鳴

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

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

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

代碼如下

'------在sheet1下
Private Sub CheckBox1_Change()
If CheckBox1.Value = True Then
Columns("A:P").Select
Selection.AutoFilter
Range("Q1").Select
ActiveSheet.Range("$A$1:$P$49").AutoFilter Field:=16, Criteria1:=RGB(112, _
48, 160), Operator:=xlFilterCellColor
Columns("A:P").Select
Range("P1").Activate
Selection.Copy
Sheets("Sheet4").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Selection.AutoFilter
Sheets("Sheet1").Select
End If
CheckBox1.Value = False
Columns("A:P").Select
Range("P1").Activate
Selection.AutoFilter
End Sub
Private Sub CommandButton1_Click()
Columns("a:p").Select
Range("p1").Activate
Selection.AutoFilter
Range("q1").Select
ActiveSheet.Range("$B$1:$Q$50").AutoFilter Field:=16, Criteria1:=RGB(112, _
48, 160), Operator:=xlFilterCellColor
Columns("a:d").Select
Selection.Copy
Sheets("Sheet4").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Columns("p:p").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Application.CutCopyMode = False
Sheets("sheet1").Select
Columns("a:p").Select
Range("p1").Activate
Selection.AutoFilter
End Sub

複製代碼

'-sheet4下
Private Sub Worksheet_Activate()
If Range("a1").Value = "編號" Then
Columns("F:O").Select
Selection.ClearContents
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End
End If
End Sub

複製代碼

[attach]6478[/attach]

作者: Hsieh 時間: 2011-6-3 08:49

回復 3# 棋語鳥鳴

Private Sub Worksheet_Activate()
[A:C] = ""
With Sheets("sheet1")
.Columns("B:Q").AutoFilter
.Range("$B$2").CurrentRegion.AutoFilter Field:=16, Criteria1:=RGB(112, _
48, 160), Operator:=xlFilterCellColor
.[C:E].SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible).Copy [A12]
.Columns("B:Q").AutoFilter
End With
End Sub

複製代碼

作者: 棋語鳥鳴 時間: 2011-6-3 22:49

回復 5# Hsieh
請問第二行A:C是什麼意思??
如果我不要複製到第二列的A B C
想直接從C3開始複製，要如何修改(意思就是不要複製C2:E2)???

作者: Hsieh 時間: 2011-6-4 01:13

Private Sub Worksheet_Activate()
[A12:C1048576] = "" '清空先前資料
With Sheets("sheet1")
.Columns("B:Q").AutoFilter '自動篩選
.Range("$B$2").CurrentRegion.AutoFilter Field:=16, Criteria1:=RGB(112, _
48, 160), Operator:=xlFilterCellColor '篩選顏色
.Range(.[C3], .[C1048576].End(xlUp).Offset(, 2)).SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible).Copy [A13] '複製可見儲存格到A13
.Columns("B:Q").AutoFilter '取消自動篩選
End With
End Sub

複製代碼

作者: 棋語鳥鳴 時間: 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 '篩選顏色<==這句不知哪裡出了問題!一直出現偵錯(改不好)??

作者: Hsieh 時間: 2011-6-4 08:29

回復 9# 棋語鳥鳴
2007版本最大列位是1048576沒錯啊，那改成65536試試
如果不是2007以後版本
接下去篩選就不會成立，因為2003版本無法以顏色篩選
若版本正確請將Q欄加上欄名稱
基本上建議EXCEL不要用顏色來統計數值
你的Q欄顏色是用格式化條件而來
應該用條件式來判斷成立與否

作者: 棋語鳥鳴 時間: 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會將文字刪掉!，所以能否簡略篩選的範圍??

作者: Hsieh 時間: 2011-6-4 19:54

.[C1048576]是要取得C欄最底下的儲存格，那就改這樣吧
.Range(.[C3], .Cells(.Rows.count,3).End(xlUp).Offset(, 2)).SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible).Copy

作者: 棋語鳥鳴 時間: 2011-6-5 12:09

回復 12# Hsieh

此句好像也是會出現錯誤!
我改了個方式使用!不過:我如果將它改成開啟sheet時立即執行，整個excel就會當掉!如果用成按鈕就不會!是因為裡面有Select的關係嗎?

Sub 測試()
'
' 測試 Macro
'
'
Application.ScreenUpdating = False
Sheets("篩選專區").Visible = xlSheetVisible
Range("A14:G47").ClearContents
Sheets("篩選專區").Select
Range("A13:H60").AutoFilter
ActiveSheet.Range("$A$13:$H$60").AutoFilter Field:=8, Criteria1:=RGB(112, _
48, 160), Operator:=xlFilterCellColor
Range("A14:G29").Copy
Sheets("總覽").Range("A14").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("篩選專區").Select
Selection.AutoFilter
Range("G12").Select
Sheets("總覽").Select
Sheets("篩選專區").Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
End Sub

複製代碼

請問我如果要將此巨集改成，開啟"總覽"工作表時!立即執行，請問要如何改??

作者: Hsieh 時間: 2011-6-5 22:20

回復 12# 棋語鳥鳴 [/

[attach]6503[/attach]
作者: 棋語鳥鳴 時間: 2011-6-6 16:36

回復 13# Hsieh

Hsieh 板大:我知道我之所以錯誤在哪了!應該是我的塞選來源是連接的格式!因為我用直接輸入的方式可以!但是利用連結別的數據檔案的!在複製時會出現錯誤!請問這樣要如何改??[attach]6507[/attach]
檔案中Sheet1為Sheet2的連接!sheet4也是要篩選sheet1的檔案!如果Sheet1的來源為手動鍵入的話!巨集不會有問題!但是Sheet1的來源為連結的話!就會出現錯誤??請問這樣要如何改巨集!可以使他在sheet1為連結時可以正常使用??
作者: Hsieh 時間: 2011-6-6 18:37

回復 14# 棋語鳥鳴
Private Sub Worksheet_Activate()

Range([A14], [G14].End(xlDown)) = ""

With Sheets("sheet1")

If .AutoFilterMode = False Then .Columns("B:Q").AutoFilter

.Range("$B$2").CurrentRegion.AutoFilter Field:=16, Criteria1:=RGB(112, _

48, 160), Operator:=xlFilterCellColor

.Range(.[C3], .Cells(.Rows.Count, 7).End(xlUp).Offset(, 2)).SpecialCells(xlCellTypeFormulas).SpecialCells(xlCellTypeVisible).Copy [A14]

.Columns("B:Q").AutoFilter

End With

End Sub
複製代碼
作者: 棋語鳥鳴 時間: 2011-6-7 06:06

回復 15# Hsieh

不好意思~不知道哪裡出了問題!只要當sheet1數值少於不知幾行時!sheet4就無法顯是正確值，但是如果多行時可以正常使用![attach]6512[/attach]
作者: Hsieh 時間: 2011-6-7 18:41

回復 16# 棋語鳥鳴

你看複製過去的公式一不一樣?
不是說過最好依照條件化格式的條件去做判斷比較好嗎?
而且為何不直接用SHEET2的原來數值來做來源，還要多一個SHEET1來用公式過渡呢?
自找麻煩罷了
作者: 棋語鳥鳴 時間: 2011-6-8 06:42

回復 17# Hsieh

因為要篩選的檔案是連接個不同的地方來的~公式一樣!後來用了另一的方式解決了!於sheet1Q欄下方增加幾個紫色儲存格數據欄為空白!這樣數據來源會多了好幾行!複製時，因為下面是空白!所以就算複製到了也沒差!

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