比较日期并更改颜色答案

【问题标题】：Compare dates and change colours比较日期并更改颜色
【发布时间】：2015-10-02 15:05:34
【问题描述】：

我有一个宏，可以在打开工作簿时将实际日期与列中的日期值进行比较。如果单元格的日期值小于实际日期，它会更改内部和字体颜色。该宏运行良好，但我做了一些一般性的更改，现在它根本不起作用。

如果通过 Si.Value=True 条件插入单元格值，则内部和字体颜色不会改变。

我用来插入日期的宏：

Private Sub Insertar_Click()

Dim ws2 As Worksheet
Set ws2 = Worksheets("ControlVentas")

ultimafila = Cells(Rows.Count, 2).End(xlUp).Row + 1

With ws2

If Si.Value = True Then
        .Cells(ultimafila, 5) = fecha_cambio
        'fecha_cambio is a Month View
Else
        .Cells(ultimafila, 5).FormulaR1C1 = "=DATE(YEAR(RC[-1])+1,MONTH(RC[-1]),DAY(RC[-1]))"
End If

End With

End Sub

我用来比较日期的宏是：

Sub Iniciar()

Dim i As Long
Dim uf As Long

fechaActual = Date

ActiveWorkbook.Sheets("ControlVentas").Activate
uf = Range("E3", Range("E3").End(xlDown)).Rows.Count
Range("E3").Select

For i = 1 To uf

    If ActiveCell.Value < fechaActual Then
        ActiveCell.Interior.Color = RGB(255, 185, 185)
        ActiveCell.Font.Color = RGB(204, 0, 0)
    Else
        ActiveCell.Offset(0, -1).Select
        Selection.Copy
        ActiveCell.Offset(0, 1).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    End If

    ActiveCell.Offset(1, 0).Select
Next

Range("B1").Select

End Sub

完整宏的一部分：

Sub Iniciar()

Dim i As Long
Dim uf As Long

fechaActual = Date

ActiveWorkbook.Sheets("ControlVentas").Activate
uf = Range("E3", Range("E3").End(xlDown)).Rows.Count
Range("E3").Select

For i = 1 To uf

    If ActiveCell.Value < fechaActual Then
        ActiveCell.Interior.Color = RGB(255, 185, 185)
        ActiveCell.Font.Color = RGB(204, 0, 0)
    Else
        ActiveCell.Offset(0, -1).Select
        Selection.Copy
        ActiveCell.Offset(0, 1).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    End If

    ActiveCell.Offset(1, 0).Select
Next

Range("B1").Select

End Sub


Sub insertar()
Dim dblEndTime As Double

ActiveSheet.Shapes("Nuevo").Fill.ForeColor.RGB = RGB(50, 95, 9)
ActiveSheet.Shapes("Nuevo").Line.BackColor.RGB = RGB(50, 95, 9)

dblEndTime = Timer + 0.1
Do While Timer < dblEndTime
    DoEvents
Loop

ActiveSheet.Shapes("Nuevo").Fill.ForeColor.RGB = RGB(85, 131, 53)
ActiveSheet.Shapes("Nuevo").Line.BackColor.RGB = RGB(85, 131, 53)

UserForm1.UserForm_Initialize
UserForm1.Show

End Sub


Sub Cambio_realizado()
Dim contador As Double
Dim ws3 As Worksheet
Set ws3 = Worksheets("ControlVentas")
Dim dblEndTime As Double
fechaActual = Date

If ActiveCell.Column = 5 Then
    If ActiveCell.Value <> "" Then
        On Error Resume Next
        ActiveCell.Value = DateAdd("yyyy", 1, ActiveCell.Value)

        If ActiveCell.Value < fechaActual Then
            ActiveCell.Interior.Color = RGB(255, 185, 185)
            ActiveCell.Font.Color = RGB(204, 0, 0)
        Else
            If ActiveCell.Interior.Color = RGB(255, 185, 185) Then
                ActiveCell.Offset(0, -1).Select
                Selection.Copy
                ActiveCell.Offset(0, 1).Select
                Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
                Application.CutCopyMode = False
            Else
            End If
        End If

        ActiveSheet.Shapes("Cambio").Fill.ForeColor.RGB = RGB(50, 95, 9)
        ActiveSheet.Shapes("Cambio").Line.BackColor.RGB = RGB(50, 95, 9)
        'ActiveCell.Offset(0, 3).Select
        'ActiveCell = ActiveCell + 1
        'ActiveCell.Offset(0, -3).Select
        If Cells(ActiveCell.Row, 1) = 13641 Or Cells(ActiveCell.Row, 1) = 13651 Or Cells(ActiveCell.Row, 1) = 1377 Then
            ws3.Cells(ActiveCell.Row, 8) = Cells(ActiveCell.Row, 8) + 1
        Else
        End If

        Select Case Cells(ActiveCell.Row, 1)
            Case Is = 13641
                If ws3.Cells(ActiveCell.Row, 9) = 0 Then
                    ws3.Cells(ActiveCell.Row, 6) = "13845 - 13847"
                Else
                    ws3.Cells(ActiveCell.Row, 6) = "13845 - 13848"
                End If
            Case Is = 1377
                If ws3.Cells(ActiveCell.Row, 9) = 0 Then
                    ws3.Cells(ActiveCell.Row, 6) = "1372 - 1374 - 1386"
                Else
                    ws3.Cells(ActiveCell.Row, 6) = "1372 - 1373 - 1374"
                End If
            Case Is = 13651
                If ws3.Cells(ActiveCell.Row, 9) = 0 Then
                    ws3.Cells(ActiveCell.Row, 6) = "1370 - 1374 - 13847"
                Else
                    ws3.Cells(ActiveCell.Row, 6) = "1370 - 1374 - 13848"
                End If
            Case Else
        End Select
     Else
     MsgBox ("Este registro está vacío." + Chr(13) + "Seleccione un registro con fecha.")
    End If
Else
MsgBox ("Seleccione un dato de la columnna 'Fecha cambio repuestos'")
End If

dblEndTime = Timer + 0.1
Do While Timer < dblEndTime
    DoEvents
Loop

ActiveSheet.Shapes("Cambio").Fill.ForeColor.RGB = RGB(85, 131, 53)
ActiveSheet.Shapes("Cambio").Line.BackColor.RGB = RGB(85, 131, 53)

End Sub


Sub eliminar()
Dim dblEndTime As Double
On Error Resume Next
ActiveCell.EntireRow.Delete

ActiveSheet.Shapes("Eliminar").Fill.ForeColor.RGB = RGB(50, 95, 9)
ActiveSheet.Shapes("Eliminar").Line.BackColor.RGB = RGB(50, 95, 9)
dblEndTime = Timer + 0.1
Do While Timer < dblEndTime
    DoEvents
Loop
ActiveSheet.Shapes("Eliminar").Fill.ForeColor.RGB = RGB(85, 131, 53)
ActiveSheet.Shapes("Eliminar").Line.BackColor.RGB = RGB(85, 131, 53)

End Sub


Public Sub UserForm_Initialize()
Dim cod As Range
Dim pro As Range
Dim cli As Range
Dim ws As Worksheet
Dim ws5 As Worksheet
Set ws = Worksheets("ListaProductos")
Set ws5 = Worksheets("ListaClientes")

codigo.Clear
For Each cod In ws.Range("CodigoProductoLista")
    With Me.codigo
        .AddItem cod.Value
        .List(.ListCount - 1, 1) = cod.Offset(0, 1).Value
    End With
Next cod

cliente.Clear
For Each cli In ws5.Range("ClienteLista")
    With Me.cliente
        .AddItem cli.Value
        .List(.ListCount - 1, 1) = cli.Offset(0, 1).Value
    End With
Next cli

No.Value = True
calendario2.Visible = False
calendario2.Refresh
calendario = Date
Me.codigo.SetFocus
End Sub


Private Sub calendario2_DateClick(ByVal DateClicked As Date)
fecha_cambio = calendario2
End Sub


Private Sub calendario_DateClick(ByVal DateClicked As Date)
fecha_compra = calendario
End Sub


Private Sub Si_Click()

If Si.Value = True Then
    calendario2.Visible = True
    calendario2.Refresh
    Label8.Visible = True
    fecha_cambio.Visible = True
Else
End If

End Sub


Private Sub No_Click()

If No.Value = True Then
    calendario2.Visible = False
    calendario2.Refresh
    Label8.Visible = False
    fecha_cambio.Visible = False
Else
End If

End Sub


Private Sub Insertar_Click()

If IsNumeric(codigo) = False Then
    codigo.Value = ""
    MsgBox ("Ingrese un número en 'Código'")
    producto = Empty
    Me.codigo.SetFocus
    Exit Sub
End If

Dim ultimafila As Long
Dim ws2 As Worksheet
Set ws2 = Worksheets("ControlVentas")
Dim codi As Integer

ultimafila = Cells(Rows.Count, 2).End(xlUp).Row + 1
penultima = ultima - 1

With ws2

    If codigo.Text <> "" Then
        Me.producto.SetFocus
    Else
        MsgBox ("Ingrese el código del producto")
        Me.codigo.SetFocus
        Exit Sub
    End If

    If producto <> "" Then
        Me.cliente.SetFocus
    Else
        MsgBox ("Ingrese el nombre del producto")
        Me.producto.SetFocus
        Exit Sub
    End If

    If cliente.Text <> "" Then
        Me.fecha_compra.SetFocus
    Else
        MsgBox ("Ingrese el nombre del cliente")
        Me.cliente.SetFocus
        Exit Sub
    End If

    If fecha_compra = Empty Then
        fecha_compra = Date
    Else
        fecha_compra = fecha_compra
    End If

    .Cells(ultimafila, 1) = Val(codigo)
    .Cells(ultimafila, 2) = producto
    .Cells(ultimafila, 3) = cliente
    'Selection.NumberFormat = "0"
    .Cells(ultimafila, 4) = fecha_compra
    'Selection.NumberFormat = "dd/mm/yyyy;@"

    If Si.Value = True Then
        .Cells(ultimafila, 5) = fecha_cambio
        'fecha_cambio is a Month View
    Else
        .Cells(ultimafila, 5).FormulaR1C1 = "=DATE(YEAR(RC[-1])+1,MONTH(RC[-1]),DAY(RC[-1]))"
    End If

    No.Value = True

    If .Cells(ultimafila, 1) = 13641 Or .Cells(ultimafila, 1) = 13651 Or .Cells(ultimafila, 1) = 1377 Then
        .Cells(ultimafila, 8) = 1
    Else
    End If

    Select Case codigo
        Case Is = 13501
            .Cells(ultimafila, 6) = "13503"
            .Cells(ultimafila, 6).Select
            Selection.HorizontalAlignment = xlCenter
        Case Is = 1359
            .Cells(ultimafila, 6) = "13581"
            .Cells(ultimafila, 6).Select
            Selection.HorizontalAlignment = xlCenter
        Case Is = 1377
            .Cells(ultimafila, 6) = "1372 - 1373 - 1374"
            .Cells(ultimafila, 6).Select
            Selection.HorizontalAlignment = xlCenter
        Case Is = 13631
            .Cells(ultimafila, 6) = "1372 - 1374"
            .Cells(ultimafila, 6).Select
            Selection.HorizontalAlignment = xlCenter
        Case Is = 13641
            .Cells(ultimafila, 6) = "13845 - 13848"
            .Cells(ultimafila, 6).Select
            Selection.HorizontalAlignment = xlCenter
        Case Is = 13651
            .Cells(ultimafila, 6) = "1370 - 1374 - 13848"
            .Cells(ultimafila, 6).Select
            Selection.HorizontalAlignment = xlCenter
        Case Is = 1441
            .Cells(ultimafila, 6) = "1444"
            .Cells(ultimafila, 6).Select
            Selection.HorizontalAlignment = xlCenter
        Case Is = 1438
            .Cells(ultimafila, 6) = "1439"
            .Cells(ultimafila, 6).Select
            Selection.HorizontalAlignment = xlCenter
        Case Is = 1466
            .Cells(ultimafila, 6) = "14661"
            .Cells(ultimafila, 6).Select
            Selection.HorizontalAlignment = xlCenter
        Case Is = 14662
            .Cells(ultimafila, 6) = "13831"
            .Cells(ultimafila, 6).Select
            Selection.HorizontalAlignment = xlCenter
        Case Else
    End Select

    .Cells(ultimafila, 7) = observaciones

End With

codigo = Empty
producto = Empty
cliente = Empty
fecha_compra = Empty
fecha_cambio = Empty
observaciones = Empty

UserForm1.UserForm_Initialize

End Sub

【问题讨论】：

fechaActual 在哪里被声明为变量？
不是。我应该将其声明为双重吗？
你的代码对我有用，就像你在这里一样，但你应该遵循 Scott 给你的建议，尝试使用应用程序对象本身，而不是使用应用程序为你做所有事情。
谢谢！我意识到为什么宏没有改变某些日期的内部和字体颜色。我更新了帖子。可以再看一遍吗？
上面的代码在哪里，在另一个子里？为什么会有不合格的引用.Cells？

标签： vba excel

【解决方案1】：

这么近

您在尝试使用宏记录器并修复它以做您想做的事情方面做得很好。

有几点：

1 如果你要循环，使用循环选择下一个单元格，那么你不需要实际选择它并使用 activecell

2 尽量避免使用.Select，它会减慢子程序的速度。

试试这个：

Sub Iniciar()

Dim i As Long
Dim ws As Worksheet
Dim cel As Range

fechaActual = Date

Set ws = ActiveWorkbook.Sheets("ControlVentas")

For Each cel In ws.Range(ws.Range("E3"), ws.Range("E3").End(xlDown).offset(-1))

    If cel.value < fechaActual Then
        cel.Interior.Color = RGB(255, 185, 185)
        cel.Font.Color = RGB(204, 0, 0)
    Else
        cel.Interior.Color = cel.offset(,-1).Interior.Color
        cel.Font.Color = cel.offset(,-1).Font.Color
    End If


Next cel

我更改了 else 语句，将单元格的内部颜色和文本颜色复制到左侧。如果左侧单元格未指示正确的配色方案，请尝试通过将 -1 降低或将其更改为正值，将偏移量向左更远地更改，它会看起来正确。

【讨论】：

感谢您的建议！数据在一个有样式的表格中，所以每一行都有不同的内部颜色，这就是Else我复制以前的列格式的原因。
@WilsonMéndezPeñalosa 我修复了其他颜色。希望您能找到并回答您的其他问题。
@WilsonMéndezPeñalosa 这可能是因为它是一个表并且它注册了最后一个空行。我已经更改了代码。
您好，我刚刚尝试了代码，但它计算的行数超过了必要的一行，我该如何减去 1？
谢谢！但是还有最后一个问题，对于所有条件为假的单元格，它应该复制上一列的格式，但是它将内部颜色设置为白色，字体颜色设置为黑色。就像默认单元格一样。