比较日期和更改颜色

时间：2015-10-02 15:05:34

标签： excel vba excel-vba

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

如果通过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

Full macro的一部分：

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

1 个答案:

答案 0 :(得分：2)

如此接近

您尝试使用宏录制器并修复它以执行您想要的操作时做得很好。

有几件事：

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更低或更改为正向更改左侧的偏移编号，它将看起来正确。

相关问题
最新问题