每分鍾將彩色單元格復制到另一張紙上

Question

我有一個帶有 DDE 鏈接的表，它同時在變化。 它在 A 列上具有條件格式，具有一些條件並更改 A 列單元格的顏色。 我想每 1 分鍾將 A 列單元格中的所有行復制到另一個帶有 VBA 的工作表。

我嘗試了下面的代碼，但它每分鍾都粘貼到結束，我想在幾分鍾內看到剛剛着色的行。

Sub color()

Dim TransIDField As Range
Dim TransIDCell As Range
Dim ATransWS As Worksheet
Dim HTransWS As Worksheet

Set ATransWS = Worksheets("XU100")
Set TransIDField = ATransWS.Range("A2", ATransWS.Range("A2").End(xlDown))
Set HTransWS = Worksheets("DASHBOARD")


For Each TransIDCell In TransIDField

    If TransIDCell.Interior.Color = RGB(255, 255, 0) Then
        
        TransIDCell.Resize(1, 10).Copy Destination:= _
            HTransWS.Range("A1").Offset(HTransWS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
            
    End If

Next TransIDCell

HTransWS.Columns.AutoFit

End Sub

Answer 1

您可以通過首先測試用於着色它們的相同邏輯來避免按顏色復制

1. 確定工作表和 scope（最后一行）
2. 確定范圍的第 20 個百分位數
3. 過濾大於 20% 的值的原始數據
4. 將過濾后的值復制/粘貼到DASHBOARD

我認為這種方法更明確一點，並且如果您的條件格式中斷，也可以確保您的宏不會受到影響。 我發現條件格式不時由於用戶錯誤而中斷，這將影響所有 stream 依賴項。

---

Sub Try()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("XU100")
Dim ps As Worksheet: Set ps = ThisWorkbook.Sheets("Dashboard")
Dim lr As Long, Target As Double, lr2 As Long
Dim CopyMe As Range

lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
lr2 = ps.Range("A" & ps.Rows.Count).End(xlUp).Row
Target = Application.WorksheetFunction.Percentile_Exc(ws.Range("A2:A" & lr), 0.8)

ws.AutoFilterMode = False

    Set CopyMe = ws.Range("A1:A" & lr)
    CopyMe.AutoFilter 1, ">" & Target
    CopyMe.Offset(1).SpecialCells(xlCellTypeVisible).Copy
    ps.Range("A" & lr2 + 1).PasteSpecial xlPasteValues

ws.AutoFilterMode = False


End Sub

---

您可能還想在嘗試使用CopyMe檢查它是否不是空白范圍。 ie If Not CopyMe is Nothing Then [Copy & Paste] End If