Если в вашей форме есть текстовое поле, в которое вы вводите дату.
Этот первый фрагмент кода гарантирует, что у вас есть дата в текстовом поле, а не что-либо еще.
Вставьте это в обычный модуль.Вы можете разместить его в форме, но в модуле позволяет использовать его в любых других формах, которые могут иметь дату.
Public Sub FormatDate(ctrl As Control)
Dim dDate As Date
Dim IsDate As Boolean
On Error GoTo ERR_HANDLE
If Replace(ctrl.Value, " ", "") <> "" Then
On Error Resume Next
dDate = CDate(ctrl.Value)
IsDate = (Err.Number = 0)
On Error GoTo -1
On Error GoTo ERR_HANDLE
If IsDate Then
ctrl.Value = Format(ctrl.Value, "dd-mmm-yyyy")
ctrl.BackColor = RGB(255, 255, 255)
Else
ctrl.BackColor = RGB(255, 0, 0)
End If
End If
EXIT_PROC:
On Error GoTo 0
Exit Sub
ERR_HANDLE:
MsgBox Err.Number & ": " & Err.Description, vbOKOnly, "FormatDate()"
Resume EXIT_PROC
End Sub
Поместите это в форму как AfterUpdate событие для вашего текстового поля:
Private Sub txtDate_AfterUpdate()
On Error GoTo ERR_HANDLE
With Me
FormatDate .txtDate
End With
EXIT_PROC:
On Error GoTo 0
Exit Sub
ERR_HANDLE:
MsgBox Err.Number & ": " & Err.Description, vbOKOnly, "txtDate_AfterUpdate()"
Resume EXIT_PROC
End Sub
Любая действительная дата будет отформатирована как дд-ммм-гггг любая недопустимая дата станет красным цветом фона элемента управления.
Далее вам нужно найти дату в строке 1 вашего листа.Опять же, это можно сохранить в обычном модуле, поэтому вы можете использовать его вне формы:
Public Function FindDate(DateValue As Date) As Range
Dim rFound As Range
With Sheet2
Set rFound = .Rows(1).Find(DateValue, .Cells(1, 1), xlValues, xlWhole)
If rFound Is Nothing Then
Set rFound = .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1)
End If
End With
Set FindDate = rFound
End Function
Это вернет ячейку, в которой находится дата, или последнюю пустую ячейку в строке 1, если дата нене найдено
Я не уверен, нужен ли вам этот бит, но затем он находит последнюю ячейку, содержащую данные в указанном номере столбца:
Public Function LastCell(wrksht As Worksheet, Col As Long) As Range
Dim lLastRow As Long
On Error Resume Next
lLastRow = wrksht.Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
On Error GoTo 0
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrksht.Cells(lLastRow, Col)
End Function
Теперь вам просто нужно присоединитькод кнопки поиска, чтобы вернуть первую пустую ячейку под указанной вами датой:
Private Sub btnFind_Click()
Dim rFoundCell As Range
'First blank cell beneath date.
Set rFoundCell = LastCell(Sheet1, FindDate(CDate(Me.txtDate)).Column).Offset(1)
End Sub
Если вы просто хотите найти дату, вы можете просто использовать:
Set rFoundCell = FindDate(CDate(Me.txtDate))
Файл справки для Find здесь .
Поиск дат может быть проблематичным в Excel: