vba - excel日期格式问题

Question

嗨，我对从一个工作簿复制信息并将其粘贴到另一个工作簿的宏有疑问。然后它创建两列并用 IF 公式填充它们以比较两个日期。这些公式会带来错误的结果，因为其中一列有另一种日期格式，我无法更改它，无论我在单元格上做什么都不起作用，只有当我删除该列的任何单元格上的值并写入日期时我可以改变格式。

所需的主要格式是 YYYY-MM-DD，但是此列设置为 dd/mm/yyyy，即使我更新单元格并将其设置为日期或自定义它根本不起作用，它总是显示错误的格式.

这是我正在处理的宏，有什么办法可以解决这个问题吗？

先感谢您。

    Sub AD_Audit()

'Last cell in column
Dim ws As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Dim wb3 As Workbook

Set ws = Worksheets(2)
With ws
    Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
    LastCellRowNumber = LastCell.Row + 1
End With

Dim Wb As Workbook, wb2 As Workbook
Dim vFile As Variant

'Set source workbook
Set Wb = ActiveWorkbook

'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
    1, "Select One File To Open", , False)

'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile

'Set selectedworkbook
Set wb2 = ActiveWorkbook

'Select cells to copy
wb2.Worksheets(2).Range("A1:BD" & ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row).Select
Selection.Copy

'Go back to original workbook you want to paste into
Wb.Activate

'Paste starting at the last empty row
Wb.Worksheets(2).Activate
Wb.Worksheets(2).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
  Application.CutCopyMode = False
Application.ScreenUpdating = True

Dim LstrDate As String
Dim LDate As Date

LstrDate = "Apr 6, 2003"
LDate = CDate(LstrDate)

'search for columns containing the data needed
Dim x As Integer
Dim lastRow As Long
lastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row


Dim rFind As Range
With Range("A:DB")
        Set rFind = .Find(What:="Account Last Updated", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not rFind Is Nothing Then
End If
End With

 Dim rFind1 As Range

    With Range("A:DB")
        Set rFind1 = .Find(What:="Termination Date", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not rFind1 Is Nothing Then

        End If
    End With

    Dim rFind2 As Range

    With Range("A:DB")
        Set rFind2 = .Find(What:="Last Password set date", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not rFind2 Is Nothing Then
        End If
    End With

'create columns and fill them with formulas
x = ActiveSheet.UsedRange.Columns.Count
ActiveSheet.Cells(1, x + 1) = "Account last updated after termination"
intcounter = 2
While (intcounter <= lastRow)
    ActiveSheet.Cells(intcounter, x + 1).Formula = "=IF(TEXT(""" & Cells(intcounter, rFind.Column) & """,""YYYY/MM/DD"")>=TEXT(""" & Cells(intcounter, rFind1.Column) & """,""YYYY/MM/DD""),""review"",""disabled"")"
    intcounter = intcounter + 1
Wend


x = ActiveSheet.UsedRange.Columns.Count
ActiveSheet.Cells(1, x + 1) = "Password After Termination"
intcounter = 2
While (intcounter <= lastRow)
    ActiveSheet.Cells(intcounter, x + 1).Formula = "=IF(TEXT(""" & Cells(intcounter, rFind2.Column) & """,""YYYY/MM/DD"")>=TEXT(""" & Cells(intcounter, rFind1.Column) & """,""YYYY/MM/DD""),""review"",""old"")"
    intcounter = intcounter + 1
Wend

'add column Actions
Worksheets(2).Range("A1").EntireColumn.Insert
Worksheets(2).Range("A1").Formula = "Actions"

'Set headers to bold text
Rows(1).Font.Bold = True


'check for filter, turn on if none exists
  If Not ActiveSheet.AutoFilterMode Then
    ActiveSheet.Range("A1:BD1").AutoFilter
  End If
  Dim Notes As Object, Maildb As Object, workspace As Object, UIdoc As Object, UserName As String
Dim MailDbName As String

ThisWorkbook.Activate
For Each Wb In Workbooks
     If Not (Wb Is ActiveWorkbook) Then Wb.Close savechanges:=False
Next


End Sub

Answer 1

日期值作为数值存储在工作表单元格中，因此可以将不同的格式应用于不同的单元格，并且仍然保留比较(或加法、减法等)的能力。您应用于每个单元格的公式会在实际值时强制以特定文本格式进行比较。

关键是将您的公式设置为使用 地址 单元格，而不是单元格内容。

所以你的单元格公式可以简单地是:
ActiveSheet.Cells(intcounter, x + 1).Formula = "=If(" & Cells(intcounter, rFind.Column).Address & ">=" & Cells(intcounter, rFind1.Column).Address & ","""review""","""disabled""")"