移動有顏色的列到其他sheet(小問題請教)

jj369963

Dear各位大大：

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

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

移動有顏色的列到其他sheet_1030.rar (11.91 KB)

下載次數: 13

2013-10-30 22:14

kimbal

回復 1# jj369963

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

1. Sub test()
   
2. 
   
3.     Dim lngRowPwd As Long, lngRowNoAns As Long
   
4.     lngRowPwd = 1
   
5.     lngRowNoAns = 1
   
6.     For Each c In Range(Range("A1"), Range("A65536").End(xlUp))
   
7.         If Application.WorksheetFunction.CountA(Range(c, c.Offset(0, 1))) = 0 Then 'A:B
   
8.             Worksheets("無帳密").Rows(lngRowPwd).Value = Rows(c.Row).Value
   
9.             lngRowPwd = lngRowPwd + 1
   
10.         ElseIf Application.WorksheetFunction.CountA(Range(c.Offset(0, 7), c.Offset(0, 94))) <> 88 Then 'H:CQ
    
11.             Worksheets("無作答").Rows(lngRowNoAns).Value = Rows(c.Row).Value
    
12.             lngRowNoAns = lngRowNoAns + 1
    
13.         End If
    
14. 
    
15.     Next
    
16. End Sub

複製代碼

GBKEE

回復 1# jj369963

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Sh(1 To 2) As Worksheet, i As Integer, R As Integer
   
4.     Set Sh(1) = Sheets("無帳密")
   
5.     Set Sh(2) = Sheets("無作答")
   
6.      Sh(1).UsedRange.Clear
   
7.      Sh(2).UsedRange.Clear
   
8.     With Sheets("sheet0")
   
9.         Sh(1).Rows(1) = .Rows(1).Value
   
10.         Sh(2).Rows(1) = .Rows(1).Value
    
11.         .Activate
    
12.         i = 2
    
13.         Do While .Cells(i, "a").FormatConditions.Count = 2
    
14.             '2003版 儲存格設定格式化可有3個條件可設公式
    
15.             .Cells(i, "a").Select          '需在設定格式化的儲存,方可計算設定格式化條件公式是否成立
    
16.             If Application.Evaluate(.Cells(i, "a").FormatConditions(1).Formula1) Then       '計算設定格式化第1個條件公式是否成立
    
17.                 R = Sh(1).UsedRange.Rows.Count + 1                                          '計算 UsedRange.Rows 的總數+1
    
18.                 Sh(1).Rows(R) = .Cells(i, "a").EntireRow.Value
    
19.             ElseIf Application.Evaluate(.Cells(i, "a").FormatConditions(2).Formula1) Then   '計算設定格式化第2個條件公式是否成立
    
20.                 R = Sh(2).UsedRange.Rows.Count + 1
    
21.                 Sh(2).Rows(R) = .Cells(i, "a").EntireRow.Value
    
22.             End If
    
23.             i = i + 1
    
24.         Loop
    
25.     End With
    
26. End Sub

複製代碼

jj369963

回復 3# GBKEE


    Dear GBKEE 版主：
   
              謝謝您的回應，但是出現一點問題

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

         感謝

下載 (23.46 KB)

2013-11-1 21:38

jj369963

回復 3# GBKEE

sorry謝謝提醒，如附檔

也謝謝版大的積極回應

test_m.rar (62.78 KB)

下載次數: 5

2013-11-1 21:55

jj369963

回復 2# kimbal


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

如附檔，請參閱

reply_1.rar (65.11 KB)

下載次數: 7

2013-11-1 22:11

GBKEE

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

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Sh(1 To 2) As Worksheet, i As Integer, R As Integer
   
4.     Set Sh(1) = ThisWorkbook.Sheets("無帳密")  '程式碼所在活頁簿的工作表
   
5.     Set Sh(2) = ThisWorkbook.Sheets("無作答")
   
6.     '****************************************************************
   
7.     'Set Sh(1) = ActiveWorkbook.Sheets("無帳密")  '作用中活頁簿的工作表
   
8.     '********************************************************************   
   
9.      Sh(1).UsedRange.Clear
   
10.      Sh(2).UsedRange.Clear
    
11.     With ThisWorkbook.Sheets("sheet0")            '程式碼所在活頁簿的工作表
    
12.     '****************************************************************
    
13.     'With ActiveWorkbook.Sheets("sheet0")         '作用中活頁簿的工作表
    
14.     '****************************************************************
    
15.         Sh(1).Rows(1) = .Rows(1).Value
    
16.         Sh(2).Rows(1) = .Rows(1).Value
    
17.         .Activate
    
18.         i = 2
    
19.         Do While .Cells(i, "a").FormatConditions.Count = 2 And .Cells(i, "a") <> ""
    
20.             '2003版 儲存格設定格式化可有3個條件可設公式
    
21.             .Cells(i, "a").Select          '需在設定格式化的儲存,方可計算設定格式化條件公式是否成立
    
22.             If Application.Evaluate(.Cells(i, "a").FormatConditions(1).Formula1) Then       '計算設定格式化第1個條件公式是否成立
    
23.                 R = Sh(1).UsedRange.Rows.Count + 1                                          '計算 UsedRange.Rows 的總數+1
    
24.                 Sh(1).Rows(R) = .Cells(i, "a").EntireRow.Value
    
25.             ElseIf Application.Evaluate(.Cells(i, "a").FormatConditions(2).Formula1) Then   '計算設定格式化第2個條件公式是否成立
    
26.                 R = Sh(2).UsedRange.Rows.Count + 1
    
27.                 Sh(2).Rows(R) = .Cells(i, "a").EntireRow.Value
    
28.             End If
    
29.             i = i + 1
    
30.         Loop
    
31.     End With
    
32. End Sub

複製代碼

jj369963

回復 7# GBKEE


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

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

感謝

test_m_1.rar (62.79 KB)

下載次數: 9

2013-11-2 17:30

GBKEE

回復 8# jj369963
再試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Sh(1 To 2) As Worksheet, R As Integer, E As Range
   
4.     Set Sh(1) = Sheets("無帳密")
   
5.     Set Sh(2) = Sheets("無作答")
   
6.      Sh(1).UsedRange.Clear
   
7.      Sh(2).UsedRange.Clear
   
8.     With Sheets("sheet0")
   
9.         Sh(1).Rows(1) = .Rows(1).Value
   
10.         Sh(2).Rows(1) = .Rows(1).Value
    
11.         .Activate
    
12.         For Each E In .UsedRange.Columns(1).Cells
    
13.             '2003版 儲存格設定格式化可有3個條件可設公式
    
14.              E.Select          '需在設定格式化的儲存,方可計算設定格式化條件公式是否成立
    
15.             If E.FormatConditions.Count = 2 Then
    
16.                 If Application.Evaluate(E.FormatConditions(1).Formula1) Then       '計算設定格式化第1個條件公式是否成立
    
17.                     R = Sh(1).UsedRange.Rows.Count + 1                                          '計算 UsedRange.Rows 的總數+1
    
18.                     Sh(1).Rows(R) = E.EntireRow.Value
    
19.                 ElseIf Application.Evaluate(E.FormatConditions(2).Formula1) Then   '計算設定格式化第2個條件公式是否成立
    
20.                     R = Sh(2).UsedRange.Rows.Count + 1
    
21.                     Sh(2).Rows(R) = E.EntireRow.Value
    
22.                 End If
    
23.             End If
    
24.         Next
    
25.     End With
    
26. End Sub

複製代碼

jj369963

回復 9# GBKEE

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

1. Sub Macro1()
   
2. '
   
3.     Cells.Select
   
4.     Selection.AutoFilter
   
5.     ActiveSheet.Range("$A$1:$CQ$376").AutoFilter Field:=6, Criteria1:=RGB(250, _
   
6.         192, 144), Operator:=xlFilterCellColor
   
7.     Selection.Copy
   
8.     Sheets("無作答").Select
   
9.     ActiveSheet.Paste
   
10.     Sheets("Sheet0").Select
    
11.     Application.CutCopyMode = False
    
12.     Rows("59:411").Select
    
13.     Selection.Delete Shift:=xlUp
    
14.     ActiveSheet.Range("$A$1:$CQ$370").AutoFilter Field:=6, Criteria1:=RGB(3, _
    
15.         255, 101), Operator:=xlFilterCellColor
    
16.     Selection.Copy
    
17.     Application.CutCopyMode = False
    
18.     Selection.Copy
    
19.     Rows("1:338").Select
    
20.     Application.CutCopyMode = False
    
21.     Selection.Copy
    
22.     Sheets("無帳密").Select
    
23.     ActiveSheet.Paste
    
24.     Sheets("無帳密").Select
    
25.     Rows("18:402").Select
    
26.     Application.CutCopyMode = False
    
27.     Rows("18:18").Select
    
28.     ActiveWindow.SmallScroll Down:=-3
    
29.     Rows("18:402").Select
    
30.     Selection.Delete Shift:=xlUp
    
31.     Selection.AutoFilter
    
32. End Sub

複製代碼