1. 首页
  2. 问答
  3. 比较日期和更改颜色

比较日期和更改颜色

2015-10-02 92 views
0

我有一个宏，该工作簿打开时，将实际日期与列中的日期值进行比较。如果单元格的日期值小于实际日期，它将更改内部和字体颜色。这个宏很好地工作，但我做了一些普遍的改变，现在根本不工作。比较日期和更改颜色

如果单元格值由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

来源

2015-10-02 Wilson Méndez Peñalosa

+0

fechaActual在哪里被声明为变量？ –

+0

不是。我应该宣布它是双重的吗？ –

+0

你的代码就像你在这里工作一样，但你应该遵循建议斯科特给你尝试使用应用程序对象本身，而不是使用应用程序来为你做所有事情。 –

回答

2

如此接近

你做了一个gr尝试使用宏记录器并修复它以做你想做的事。

几件事情：

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

来源

2015-10-02 15:21:31

+0

感谢您的咨询！数据在一个带有样式的表格中，因此每行都有不同的内部颜色，这就是'Else'中我复制以前列格式的原因。 –

+0

@WilsonMéndezPeñalosa我修正了其他的着色问题。我希望你能找到并回答你的其他问题。 –

+1

@WilsonMéndezPeñalosa这可能是因为它是一个表，它注册了最后一个空行。我改变了代码。 –

相关问题

 相关问题