Ошибка автоматизации Excel - форматирование A Дата

Question

Мой код приведен ниже. Я пытаюсь создать новый лист на основе уникальных значений в столбце Date. Если я не форматировал дату должным образом,

Я получаю неправильную ошибку имени листа, из-за /. Однако при попытке форматировать дату, чтобы избежать этой ошибки, я получаю ошибку автоматизации, и макрос завершается в последней строке, которую я разместил здесь.

Пожалуйста, помогите. :)

Sub Analyze() 
Dim DateColumn As Range 
Dim theDate As Range 
Dim theNextDate As Range 
Dim theWorksheet As Worksheet 
Dim thenewWorksheet As Worksheet 
Const DateColumnCell As String = "Date" 
Set theWorksheet = Sheets("Main") 
Set DateColumn = theWorksheet.UsedRange.Find(DateColumnCell, , xlValues, xlWhole) 

'Make sure you found something 
If Not DateColumn Is Nothing Then 
    'Go through each cell in the column 
    For Each theDate In Intersect(DateColumn.EntireColumn, theWorksheet.UsedRange).Cells 
     'skip the header and empty cells 
     If Not IsEmpty(theDate.Value) And theDate.Address <> DateColumn.Address Then 
      'see if a sheet already exists 
      On Error Resume Next 
       Set thenewWorksheet = theWorksheet.Parent.Sheets(DateColumn.Value) 
      On Error GoTo 0 


      'if it doesn't exist, make it 
      If thenewWorksheet Is Nothing Then 
       Set thenewWorksheet = theWorksheet.Parent.Worksheets.Add 
       thenewWorksheet.Name = Format(theDate.Value, "Long Date") 

Answer 1

Прежде всего, вы используете неправильное значение в

Set thenewWorksheet = theWorksheet.Parent.Sheets(DateColumn.Value) 

Это должно быть theDate.Value, не DateColumn.Value.

Но для обработки неверного формата, я предлагаю это расширение кода:

 Dim NewSheetName As String 

     For Each theDate In Intersect(DateColumn.EntireColumn, theWorksheet.UsedRange).Cells 
     'skip the header and empty cells 
     If Not IsEmpty(theDate.Value) And theDate.Address <> DateColumn.Address Then 
      'see if a sheet already exists 
      NewSheetName = Format(theDate.Value, "yyyy-mm-dd") 
      Set thenewWorksheet = Nothing 
      On Error Resume Next 
       Set thenewWorksheet = theWorksheet.Parent.Sheets(NewSheetName) 
      On Error GoTo 0 

      'if it doesn't exist, make it 
      If thenewWorksheet Is Nothing Then 
       Set thenewWorksheet = theWorksheet.Parent.Worksheets.Add 
       thenewWorksheet.Name = NewSheetName 
      End If 
     End If 
    Next 

Используйте пользовательский формат для даты, чтобы убедиться, что все символы, содержащиеся законны, на имени листа,. Во-вторых, найдите ту же строку в именах существующих листов, что и предполагаемое имя нового листа.

редактировать:

Исправлена ​​ошибка другой: указатель thenewWorksheet проверяется на Nothing, чтобы увидеть, если лист с таким именем уже существует. В следующей итерации цикла этот указатель по-прежнему указывает на последний созданный лист! Таким образом, тест будет всегда положительным после создания первого листа. Чтобы исправить, сбросьте указатель перед тестом.