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

6^# 跳轉到 »

發表於 2013-11-1 22:11 | 只看該作者

回復 2# kimbal

Dear kimbal 版大 :

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

如附檔，請參閱

reply_1.rar (65.11 KB)

5^#

發表於 2013-11-1 21:57 | 只看該作者

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

回復 3# GBKEE

sorry謝謝提醒，如附檔

也謝謝版大的積極回應

test_m.rar (62.78 KB)

4^#

發表於 2013-11-1 21:38 | 只看該作者

回復 3# GBKEE

Dear GBKEE 版主：

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

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

      感謝

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

論壇貢獻勳章

2^#

發表於 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

複製代碼

懂得發問,答案就會在其中

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