返回列表 上一主題 發帖

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

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

Dear各位大大:

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

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

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

回復 1# jj369963

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

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

  13.     Next
  14. End Sub
複製代碼
懂得發問,答案就會在其中

今日の一秒は  明日にない
http://kimbalko-chi.blogspot.com
http://kimbalko.blogspot.com

TOP

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 3# GBKEE


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

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

         感謝

error1.JPG
2013-11-1 21:38

TOP

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

回復 3# GBKEE

sorry謝謝提醒,如附檔

也謝謝版大的積極回應

test_m.rar (62.78 KB)

TOP

回復 2# kimbal


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

如附檔,請參閱

reply_1.rar (65.11 KB)

TOP

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 7# GBKEE


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

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

感謝

test_m_1.rar (62.79 KB)

TOP

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

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

回復 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
複製代碼

TOP

        靜思自在 : 有心就有福,有願就有力,自造福田,自得福緣。
返回列表 上一主題