Заменить текст с помощью регулярных выражений в Excel-VBA

Question

Я данных в Excel нравится следующим образом (одна строка здесь - одна ячейка в Excel):

07 July 2015 12:02 – 14 July 2015 17:02 
12 August 2015 22:02 – 01 September 2015 11:02 

Я хочу написать макрос, который будет удалять все данные времени (например, "12:02") в выборе пользователя (несколько ячеек), чтобы выглядеть следующим образом:

07 July 2015 – 14 July 2015 
12 August 2015 – 01 September 2015 

Когда все "времена", где аналогично ("00:00") этот макрос работал отлично:

Но тогда информация о времени перестала быть единой, поэтому я решил использовать RegEx. Проблема в том, что я не могу найти правильный способ сделать это на VBA. Я пробовал этот макрос:

Sub delete_time() 
    Dim RegEx As Object 
    Set RegEx = CreateObject("VBScript.RegExp") 
    On Error Resume Next 

    RegEx.Global = True 
    RegEx.Pattern = "\d\d\:\d\d" 
    ActiveDocument.Range = _ 
     RegEx.Replace(ActiveDocument.Range, "") 
End Sub 

Но это не сработало. Также попытались «[0-9] {2}: [0-9] {2}" и "[0-9] [0-9]: [0-9] [0-9]" шаблоны, но ничего не изменилось. Так что проблема должна быть в моем непонимании VBA (я новичок в этом).

Может ли кто-нибудь помочь?

Answer 1

Проблема с вашим выбором.

ActiveDocument.Range = _ 
RegEx.Replace(ActiveDocument.Range, "") 

ActiveDocument не существует в пространстве имен Excel. У нас есть ActiveWorkbook или ThisWorkbook, но теперь вам нужен Selection.

Используйте для каждого цикла для перебора всех ячеек в текущем отборе, как это:

Dim myCell As Range 

For Each myCell In Selection.Cells 
    myCell.Value = RegEx.Replace(myCell.Value, "") 
Next 

Answer 2

Самый простой подход мне кажется, использовать LEFT и RIGHT функции для извлечения двух отдельных временных меток, а затем преобразовать эти временные метки даты, используя TEXT функцию. Вероятно, самый простой в Excel напрямую, но если вы хотите идти вниз маршрут VBA, то пример решения ниже:

' Taking a random date from Cell A1 
DateRange = Range("A1") 

' Extracting the first timestamp 
FirstTimeStamp = Left(DateRange, Application.Find(" – ", DateRange)) 

' Converting to required date format 
FirstDate = Application.Text(FirstTimeStamp, "dd-mmm-yyyy") 

LastTimeStamp = Right(DateRange, Application.Find(" – ", DateRange)) 

LastDate = Application.Text(LastTimeStamp, "dd-mmm-yyyy") 

Answer 3

Более быстрый подход был бы совместить RegExp с вариантом массива:

'Press Alt + F11 to open the Visual Basic Editor (VBE) 
'From the Menu, choose Insert-Module. 
'Paste the code into the right-hand code window. 
'Press Alt + F11 to close the VBE 
'In Xl2003 Goto Tools … Macro … Macros and double-click KillDate 

Sub KillDate() 
    Dim rng1 As Range 
    Dim rngArea As Range 
    Dim lngRow As Long 
    Dim lngCol As Long 
    Dim lngCalc As Long 
    Dim objReg As Object 
    Dim X() 


    On Error Resume Next 
    Set rng1 = Application.InputBox("Select range for the replacement", "User select", Selection.Address, , , , , 8) 
    If rng1 Is Nothing Then Exit Sub 
    On Error GoTo 0 

    'See Patrick Matthews excellent article on using Regular Expressions with VBA 
    Set objReg = CreateObject("vbscript.regexp") 
    objReg.Pattern = "\d\d\:\d\d" 
    objReg.Global = True 

    'Speed up the code by turning off screenupdating and setting calculation to manual 
    'Disable any code events that may occur when writing to cells 
    With Application 
     lngCalc = .Calculation 
     .ScreenUpdating = False 
     .Calculation = xlCalculationManual 
     .EnableEvents = False 
    End With 

    'Test each area in the user selected range 

    'Non contiguous range areas are common when using SpecialCells to define specific cell types to work on 
    For Each rngArea In rng1.Areas 
     'The most common outcome is used for the True outcome to optimise code speed 
     If rngArea.Cells.Count > 1 Then 
      'If there is more than once cell then set the variant array to the dimensions of the range area 
      'Using Value2 provides a useful speed improvement over Value. On my testing it was 2% on blank cells, up to 10% on non-blanks 
      X = rngArea.Value2 
      For lngRow = 1 To rngArea.Rows.Count 
       For lngCol = 1 To rngArea.Columns.Count 
        'replace the leading zeroes 
        X(lngRow, lngCol) = objReg.Replace(X(lngRow, lngCol), vbNullString) 
       Next lngCol 
      Next lngRow 
      'Dump the updated array sans leading zeroes back over the initial range 
      rngArea.Value2 = X 
     Else 
      'caters for a single cell range area. No variant array required 
      rngArea.Value = objReg.Replace(rngArea.Value, vbNullString) 
     End If 
    Next rngArea 

    'cleanup the Application settings 
    With Application 
     .ScreenUpdating = True 
     .Calculation = lngCalc 
     .EnableEvents = True 
    End With 

    Set objReg = Nothing 
End Sub