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

excel上的日期格式问题

0 个答案: