Excel VBA單元格格式，如果是Statemets

Question

我有一張用於銷售條目的工作表，它有15個不同的列，根據在單元格中輸入的內容進行格式化。 這是簡單的格式化，轉換為適當的情況，這樣的事情。

縮短版的代碼是：

Private Sub Worksheet_Change(ByVal target As Range)
On Error GoTo Cleanup
Application.EnableEvents = False: Application.ScreenUpdating = False: 
Application.Calculation = xlCalculationManual ' etc..

Dim rName As String
If Not (Application.Intersect(target, Range("C2:C" & Me.Cells(Me.Rows.Count,"C").End(xlDown).Row)) Is Nothing) Then
    rName = target.Value2
    target.Value2 = UCase(Trim(rName))
End If

14x more above the above (1 each column)

Cleanup:
Application.EnableEvents = True: Application.ScreenUpdating = True: 
Application.Calculation = xlCalculationAutomatic ' etc..

我把它設置為手動，然后自動的原因是因為如果我不這樣做，Excel會停止運行。 我假設因為當用戶輸入數據時，它會更改隱藏列的值，並再次觸發Change事件。 它現在的工作方式很好，但是在用戶輸入數據后檢查和格式化每個單元格后只有一兩秒的延遲，所以最后我想知道是否有更快的方法來完成它。

謝謝！

Answer 1

一個明顯的問題：

• Me.Cells(Me.Rows.Count,"C").End( xlDown ).Row 'returns row 1,048,576

應該

• Me.Cells(Me.Rows.Count,"C").End( xlUp ).Row

嘗試這個：

---

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.CountLarge = 1 Then

        If Not (Application.Intersect(Target, Me.UsedRange.Columns("C")) Is Nothing) Then

            Application.EnableEvents = False
            Application.Calculation = xlCalculationManual ' etc..
                On Error Resume Next
                Target.Value2 = UCase$(Trim$(Target.Value2))
                On Error GoTo 0
            Application.EnableEvents = True
            Application.Calculation = xlCalculationAutomatic ' etc..

        End If
    End If
End Sub

---

筆記：

• 關閉和打開Application.ScreenUpdating比更新單元格花費的時間更長
• 字符串版本（修剪$）明顯更快〜約10-30％......“ ， UCase $（）也是如此

Answer 2

嘗試你的相交，

If Not Application.Intersect(target, target.parent.usedrange) Is Nothing Then

工作表的.UsedRange屬性是事先確定的。 如果您在usedrange之外創建了一個條目，則usedrange會立即擴展以包含它。 這稱為“開銷”，這是vba比C或hex慢的原因之一。

在確定目標中的一個或多個單元格涉及您要執行的操作后，解析目標中的每個單元格以確定應如何處理它。

Answer 3

你可以試試這個：

Private Sub Worksheet_Change(ByVal target As Range)
    If Intersect(target, Columns("C:Q")) Is Nothing Then Exit Sub ' exit if changed cells are completely outside relevant columns (change "C:Q" to your actual relevant columns indexes)

    Application.EnableEvents = False: Application.ScreenUpdating = False:
    Application.Calculation = xlCalculationManual ' etc..
    On Error GoTo Cleanup

    With Intersect(target, Intersect(UsedRange, Columns("C:Q"))) 'consider only changed cells in relevant columns (change "C:Q" to your actual relevant columns indexes)
        .Value2 = UCase(Trim(.Value2))
    End With

Cleanup:
    Application.EnableEvents = True: Application.ScreenUpdating = True:
    Application.Calculation = xlCalculationAutomatic ' etc..
End Sub