比较date和更改颜色
我有一个macros，比较实际date和列中的date值，打开工作簿时。 如果单元格的date值小于实际date，则会更改内部和字体颜色。 这个macros很好，但是我做了一些普遍的改变，现在根本不工作。
如果单元格值由Si.Value = True条件插入，则内部和字体颜色不会更改。
我插入date的macros：
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 我比较date的macros是：
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
完整macros的一部分：
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
很近
你做了一个伟大的工作，试图使用macroslogging器，并修复它做你想要的。
几件事情：
1如果要循环，使用循环select下一个单元，那么不需要实际select它并使用活动单元
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语句，将单元格的内部颜色和文本颜色复制到左侧。 如果左侧的单元格没有指出正确的配色scheme，则可以通过增加-1更低的值或者将其更改为正值来改变偏移号码的位置。