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

標題: 移動有顏色的列到其他sheet(小問題請教) [打印本頁]

作者: jj369963 時間: 2013-10-30 22:14 標題: 移動有顏色的列到其他sheet(小問題請教)

Dear各位大大：

請教小問題，如附檔，移動已格式化設定的列到不同sheet

再煩請論壇的各位多多指導，謝謝

[attach]16514[/attach]

作者: kimbal 時間: 2013-11-1 00:27

回復 1# jj369963

老版EXCEL不能經VBA選出"條件格式"的顏色.
可以真表用代碼寫出

Sub test()
Dim lngRowPwd As Long, lngRowNoAns As Long
lngRowPwd = 1
lngRowNoAns = 1
For Each c In Range(Range("A1"), Range("A65536").End(xlUp))
If Application.WorksheetFunction.CountA(Range(c, c.Offset(0, 1))) = 0 Then 'A:B
Worksheets("無帳密").Rows(lngRowPwd).Value = Rows(c.Row).Value
lngRowPwd = lngRowPwd + 1
ElseIf Application.WorksheetFunction.CountA(Range(c.Offset(0, 7), c.Offset(0, 94))) <> 88 Then 'H:CQ
Worksheets("無作答").Rows(lngRowNoAns).Value = Rows(c.Row).Value
lngRowNoAns = lngRowNoAns + 1
End If
Next
End Sub

複製代碼

作者: GBKEE 時間: 2013-11-1 06:45

回復 1# jj369963

Option Explicit
Sub Ex()
Dim Sh(1 To 2) As Worksheet, i As Integer, R As Integer
Set Sh(1) = Sheets("無帳密")
Set Sh(2) = Sheets("無作答")
Sh(1).UsedRange.Clear
Sh(2).UsedRange.Clear
With Sheets("sheet0")
Sh(1).Rows(1) = .Rows(1).Value
Sh(2).Rows(1) = .Rows(1).Value
.Activate
i = 2
Do While .Cells(i, "a").FormatConditions.Count = 2
'2003版儲存格設定格式化可有3個條件可設公式
.Cells(i, "a").Select '需在設定格式化的儲存,方可計算設定格式化條件公式是否成立
If Application.Evaluate(.Cells(i, "a").FormatConditions(1).Formula1) Then '計算設定格式化第1個條件公式是否成立
R = Sh(1).UsedRange.Rows.Count + 1 '計算 UsedRange.Rows 的總數+1
Sh(1).Rows(R) = .Cells(i, "a").EntireRow.Value
ElseIf Application.Evaluate(.Cells(i, "a").FormatConditions(2).Formula1) Then '計算設定格式化第2個條件公式是否成立
R = Sh(2).UsedRange.Rows.Count + 1
Sh(2).Rows(R) = .Cells(i, "a").EntireRow.Value
End If
i = i + 1
Loop
End With
End Sub

複製代碼

作者: jj369963 時間: 2013-11-1 21:38

回復 3# GBKEE

Dear GBKEE 版主：

            謝謝您的回應，但是出現一點問題

         如果您有空，可以再麻煩您看一下

      感謝

[attach]16549[/attach]

作者: jj369963 時間: 2013-11-1 21:57

本帖最後由 jj369963 於 2013-11-1 22:03 編輯

回復 3# GBKEE

sorry謝謝提醒，如附檔

也謝謝版大的積極回應

[attach]16550[/attach]

作者: jj369963 時間: 2013-11-1 22:11

回復 2# kimbal

Dear kimbal 版大 :

Thanks your reply, but it didn't work.
1.資料筆少時，有搬移但是未搬移完全
2.資料筆多時完全沒反應

如附檔，請參閱

[attach]16551[/attach]

作者: GBKEE 時間: 2013-11-2 07:00

回復 6# jj369963
附檔有2個檔案(工作表名稱都相同)有同時開啟,執行EX程式嗎?

Option Explicit
Sub Ex()
Dim Sh(1 To 2) As Worksheet, i As Integer, R As Integer
Set Sh(1) = ThisWorkbook.Sheets("無帳密") '程式碼所在活頁簿的工作表
Set Sh(2) = ThisWorkbook.Sheets("無作答")
'****************************************************************
'Set Sh(1) = ActiveWorkbook.Sheets("無帳密") '作用中活頁簿的工作表
'********************************************************************
Sh(1).UsedRange.Clear
Sh(2).UsedRange.Clear
With ThisWorkbook.Sheets("sheet0") '程式碼所在活頁簿的工作表
'****************************************************************
'With ActiveWorkbook.Sheets("sheet0") '作用中活頁簿的工作表
'****************************************************************
Sh(1).Rows(1) = .Rows(1).Value
Sh(2).Rows(1) = .Rows(1).Value
.Activate
i = 2
Do While .Cells(i, "a").FormatConditions.Count = 2 And .Cells(i, "a") <> ""
'2003版儲存格設定格式化可有3個條件可設公式
.Cells(i, "a").Select '需在設定格式化的儲存,方可計算設定格式化條件公式是否成立
If Application.Evaluate(.Cells(i, "a").FormatConditions(1).Formula1) Then '計算設定格式化第1個條件公式是否成立
R = Sh(1).UsedRange.Rows.Count + 1 '計算 UsedRange.Rows 的總數+1
Sh(1).Rows(R) = .Cells(i, "a").EntireRow.Value
ElseIf Application.Evaluate(.Cells(i, "a").FormatConditions(2).Formula1) Then '計算設定格式化第2個條件公式是否成立
R = Sh(2).UsedRange.Rows.Count + 1
Sh(2).Rows(R) = .Cells(i, "a").EntireRow.Value
End If
i = i + 1
Loop
End With
End Sub

複製代碼

作者: jj369963 時間: 2013-11-2 17:30

回復 7# GBKEE

Dear GBKEE版大：
您好
附檔有2個檔案(工作表名稱都相同)有同時開啟,執行EX程式嗎?
回覆：我沒有同時開啟

另外執行語法後只有標題列移過去，格式化的列沒有移到對應的sheet
這次沒有跑出錯誤視窗
不知問題在哪??
再煩請有空之餘，指教與協助

感謝

[attach]16554[/attach]

作者: GBKEE 時間: 2013-11-3 07:05

回復 8# jj369963
再試試看

Option Explicit
Sub Ex()
Dim Sh(1 To 2) As Worksheet, R As Integer, E As Range
Set Sh(1) = Sheets("無帳密")
Set Sh(2) = Sheets("無作答")
Sh(1).UsedRange.Clear
Sh(2).UsedRange.Clear
With Sheets("sheet0")
Sh(1).Rows(1) = .Rows(1).Value
Sh(2).Rows(1) = .Rows(1).Value
.Activate
For Each E In .UsedRange.Columns(1).Cells
'2003版儲存格設定格式化可有3個條件可設公式
E.Select '需在設定格式化的儲存,方可計算設定格式化條件公式是否成立
If E.FormatConditions.Count = 2 Then
If Application.Evaluate(E.FormatConditions(1).Formula1) Then '計算設定格式化第1個條件公式是否成立
R = Sh(1).UsedRange.Rows.Count + 1 '計算 UsedRange.Rows 的總數+1
Sh(1).Rows(R) = E.EntireRow.Value
ElseIf Application.Evaluate(E.FormatConditions(2).Formula1) Then '計算設定格式化第2個條件公式是否成立
R = Sh(2).UsedRange.Rows.Count + 1
Sh(2).Rows(R) = E.EntireRow.Value
End If
End If
Next
End With
End Sub

複製代碼

作者: jj369963 時間: 2013-11-3 18:07

本帖最後由 jj369963 於 2013-11-3 18:10 編輯

回復 9# GBKEE

Dear GBKEE版大:
您好
1.測試後，只搬移標題列，格式化的列並未搬移
謝謝，再煩請指教
另外這是我用錄製做的語法來套用，也出錯，但時有時有把部分列移過去，
再勞煩您看一下了，感謝

Sub Macro1()
'
Cells.Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$CQ$376").AutoFilter Field:=6, Criteria1:=RGB(250, _
192, 144), Operator:=xlFilterCellColor
Selection.Copy
Sheets("無作答").Select
ActiveSheet.Paste
Sheets("Sheet0").Select
Application.CutCopyMode = False
Rows("59:411").Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("$A$1:$CQ$370").AutoFilter Field:=6, Criteria1:=RGB(3, _
255, 101), Operator:=xlFilterCellColor
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Rows("1:338").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("無帳密").Select
ActiveSheet.Paste
Sheets("無帳密").Select
Rows("18:402").Select
Application.CutCopyMode = False
Rows("18:18").Select
ActiveWindow.SmallScroll Down:=-3
Rows("18:402").Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter
End Sub

複製代碼

作者: luhpro 時間: 2013-11-6 21:33

回復 4# jj369963
會發生溢位有可能是 Dim i As Integer 的關係,
因為列號最大可達到65536 ,
所以建議改用 Dim i As Long ,
較不易發生溢位的情形.

回復 10# jj369963
以你提供的範例檔案,
套用 9# 的程式並不會發生你所說的情形呢.
建議你對原始檔案中的需要格式化條件的所有儲存格,
再確認一次所套用的條件內容是否都一樣.

只要 Mark 所有需套用相同格式條件的儲存格,
再按格式 -> 設定格式化條件看看是否都是相同的條件公式,
若是你看到 "空白"(沒有內容) 的條件內容,
那就是被 Mark 的儲存格有不同的條件存在.
請確認看看.

作者: GBKEE 時間: 2013-11-7 15:15

本帖最後由 GBKEE 於 2013-11-7 15:23 編輯

回復 10# jj369963
如圖示依你6#的檔案執行7#的程式,
你說的執行語法後只有標題列移過去，格式化的列沒有移到對應的sheet,(百思不解..)
2003版中 RGB(3, 255, 101) -> 傳回一個數值 Criteria1=RGB(3, 255, 101) -> 這函數傳回的數字

'xlFilterCellColor這參數為2010版的不適用2003
ActiveSheet.Range("$A$1:$CQ$370").AutoFilter Field:=6, Criteria1:=RGB(3, 255, 101), Operator:=xlFilterCellColor

複製代碼

[attach]16623[/attach]

作者: jj369963 時間: 2013-11-8 23:08

回復 12# GBKEE

Dear GBKEE 版大：

非常謝謝您的回覆，而且回覆的好詳細，感謝。
『你說的執行語法後只有標題列移過去，格式化的列沒有移到對應的sheet,(百思不解..)』
  回覆：如附檔
不過我在想會不會是excel版本的差異(???)，因為版大有執行出來，所以問題應該在我這邊。

  謝謝版大用心且詳細的回覆

[attach]16650[/attach]

作者: Hsieh 時間: 2013-11-9 00:23

回復 13# jj369963
2003版本與其他新版的格式化條件公式，
並不會因為作用中儲存格位置改變而變動相對參照的部分公式，
所以，還找不出可個別判斷條件成立與否的函數或方法
退而求其次，置換格式化條件公式的參照列位

Sub ex()
Dim A As Range, f As FormatCondition, Rng(1 To 2) As Range
With Sheet1
For Each A In .Range(.[A2], .[C2].End(xlDown).Offset(, -2)).SpecialCells(xlCellTypeAllFormatConditions)
For i = 1 To A.FormatConditions.Count
If Evaluate(Replace(A.FormatConditions(i).Formula1, 1, A.Row)) > 0 Then
If Rng(i) Is Nothing Then Set Rng(i) = Union(.[A1], A) Else Set Rng(i) = Union(Rng(i), A)
Exit For
End If
Next
Next
End With
sht = Array("無帳密", "無作答")
For i = 1 To 2
Rng(i).EntireRow.Copy Sheets(sht(i - 1)).[A1]
Sheets(sht(i - 1)).UsedRange.FormatConditions.Delete '清除格式化條件
Next
End Sub

複製代碼

作者: jj369963 時間: 2013-11-11 11:38

回復 14# Hsieh

Dear  Hsieh 超版:

      非常感謝您的補充說明，還是一如既往的熱心，it works.
         真是太感謝了，也謝謝GBKEE熱心的指導
         感謝2位

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