Need VBA code to search for a consistently formatted date string within the cells in a row and ALT+Enter infront of the date

[KlayontKress]

To all,


As the title says, I'm looking for a VBA script that will always look in all of the cells in Row 8 for a date string formatted like "2019-10-09" and do an "Alt+Enter" in front of the date to move it down to its own line. We currently have employees doing this manually 1 cell at a time on our quotes and this takes forever. a VBA script could save between 5 and 20 minutes on a particular quote to our customers which really adds up throughout the day in lost productivity, would allow for the employee to slow down and better check their work on a more critical part of their job, and removes a tedious annoyance.

We have a program that dumps data to excel, and the room names for what we designed and priced for our clients are in individual columns. Our program allows us to put a date at the end, but we can't put a return in front of it prior to coming to excel. The customers want this date on its own line so that it's easier for them to see when the room was last modified, but they don't want us to increase the cell width to achieve this. A sample room name would be "STANDARD KITCHEN- ISLAND- 2019-10-09". We occationally run into instances where the designer/quoter will forget to leave a space between the room name and the date, so the date won't always go to its own line even if there was space because it's tied to a previous string.
The easiest solution is a macro to do what we are doing by hand, but I don't know how to find a date string within a cell and always return before the first number in that string.


Any help anyone can provide would be greatly appreciated.

Thanks,

 

[pjmorris]

Assuming that all you need to do is run the macro on the active cell try this. Go to the relevant cell and run the macro, it will identify the first number in the string and put a Chr$(10) in front of it. It doesn't check that that number is actually the year part of a date, though it probably could be made to do so:

Sub addCR_LF()
    Dim nDate As Integer
    Dim nMonth As Integer
    Dim nDay As Integer
    Dim strTestString As String
    Dim Strings() As String
    
    Dim n As Integer 'general counter
    Dim m As Integer 'general counter
    
    strTestString = ""
    
    Strings = Split(ActiveCell, "-")
    
    For n = 0 To UBound(Strings)
        If IsNumeric(Trim(Strings(n))) Then Exit For
    Next n
    
    For m = 0 To UBound(Strings)
        If m = n Then strTestString = strTestString & Chr$(10)
        If m <> 0 Then strTestString = strTestString & "-"
        strTestString = strTestString & Strings(m)
    Next m
    ActiveCell = strTestString
End Sub

 

[pjmorris]

Actually, couldn't resist adding in checking of the date:

Sub addCR_LF()
    Dim nDate As Integer
    Dim nMonth As Integer
    Dim nDay As Integer
    Dim strTestString As String
    Dim Strings() As String
    
    Dim n As Integer 'general counter
    Dim m As Integer 'general counter
    
    strTestString = ""
    
    Strings = Split(ActiveCell, "-")
    
    On Error GoTo leave
    
    For n = 0 To UBound(Strings)
        If IsNumeric(Trim(Strings(n))) Then
            If IsDate(Trim(Strings(n)) & "-" & Trim(Strings(n + 1)) & "-" & Trim(Strings(n + 2))) Then
                Exit For
            Else
                Exit Sub
            End If
        End If
    Next n
    
    For m = 0 To UBound(Strings)
        If m = n Then strTestString = strTestString & Chr$(10)
        If m <> 0 Then strTestString = strTestString & "-"
        strTestString = strTestString & Strings(m)
    Next m
    ActiveCell = strTestString

leave:
    On Error GoTo 0

End Sub

hope it helps.

 

[JoeMo]

We have a program that dumps data to excel, and the room names for what we designed and priced for our clients are in individual columns. Our program allows us to put a date at the end, but we can't put a return in front of it prior to coming to excel. The customers want this date on its own line so that it's easier for them to see when the room was last modified, but they don't want us to increase the cell width to achieve this. A sample room name would be "STANDARD KITCHEN- ISLAND- 2019-10-09". We occationally run into instances where the designer/quoter will forget to leave a space between the room name and the date, so the date won't always go to its own line even if there was space because it's tied to a previous string.
The easiest solution is a macro to do what we are doing by hand, but I don't know how to find a date string within a cell and always return before the first number in that string.


Any help anyone can provide would be greatly appreciated.

Thanks,

Assuming "own line" means the date remains in the cell and is separated by alt +enter and that the data always has the format in your example, this should handle the case where the space between room name and date has been forgotten.

Sub KlayontKress()
'select the cells you want to modify first, then run this macro
Dim c As Range, x As Variant, i As Long
Application.ScreenUpdating = False
For Each c In Selection
    For i = 1 To Len(c.Value)
        If (Mid(c.Value, i, 2) Like "[A-Z]" & "-" And Mid(c.Value, i + 2, 1) Like "[0-9]") Then
            c.Value = Mid(c.Value, 1, i - 1) & Replace(c.Value, "-", "- ", i, 1)
            Exit For
        End If
    Next i
    x = Split(c, " ")
    For i = LBound(x) To UBound(x)
        If IsDate(x(i)) Then
            x(i) = Chr(10) & x(i) & Chr(10)  'Remove the "& Chr(10) if date is always at the end of the string
        End If
    Next i
    With c
        .Value = Join(x, " ")
        .WrapText = True
        .EntireColumn.AutoFit
    End With
Next c
Application.ScreenUpdating = True
End Sub

 

[KlayontKress]

Actually, couldn't resist adding in checking of the date:

Sub addCR_LF()
    Dim nDate As Integer
    Dim nMonth As Integer
    Dim nDay As Integer
    Dim strTestString As String
    Dim Strings() As String
   
    Dim n As Integer 'general counter
    Dim m As Integer 'general counter
   
    strTestString = ""
   
    Strings = Split(ActiveCell, "-")
   
    On Error GoTo leave
   
    For n = 0 To UBound(Strings)
        If IsNumeric(Trim(Strings(n))) Then
            If IsDate(Trim(Strings(n)) & "-" & Trim(Strings(n + 1)) & "-" & Trim(Strings(n + 2))) Then
                Exit For
            Else
                Exit Sub
            End If
        End If
    Next n
   
    For m = 0 To UBound(Strings)
        If m = n Then strTestString = strTestString & Chr$(10)
        If m <> 0 Then strTestString = strTestString & "-"
        strTestString = strTestString & Strings(m)
    Next m
    ActiveCell = strTestString

leave:
    On Error GoTo 0

End Sub

hope it helps.

much appreciated for the help. Is there a way to modify this to do it for every cell in a row that has data in it? I need to apply this to all of row 8.

 

[pjmorris]

Try this, simply select the cells you want to check/change and then run the macro.

Sub addCR_LF()

    Dim cTest As Range
    Dim strTestString As String
    Dim Strings() As String
   
    Dim n As Integer 'general counter
    Dim m As Integer 'general counter
   
    
    For Each cTest In Selection
         strTestString = ""
        
         Strings = Split(cTest, "-")
        
         On Error GoTo leave
        
         For n = 0 To UBound(Strings)
             If IsNumeric(Trim(Strings(n))) Then
                 If IsDate(Trim(Strings(n)) & "-" & Trim(Strings(n + 1)) & "-" & Trim(Strings(n + 2))) Then
                     Exit For
                 Else
                     Exit Sub
                 End If
             End If
         Next n
        
         For m = 0 To UBound(Strings)
             If m = n Then strTestString = strTestString & Chr$(10)
             If m <> 0 Then strTestString = strTestString & "-"
             strTestString = strTestString & Strings(m)
         Next m
         cTest = strTestString
    Next cTest

leave:
    On Error GoTo 0

End Sub

 

[KlayontKress]

Try this, simply select the cells you want to check/change and then run the macro.

Sub addCR_LF()

    Dim cTest As Range
    Dim strTestString As String
    Dim Strings() As String
  
    Dim n As Integer 'general counter
    Dim m As Integer 'general counter
  
   
    For Each cTest In Selection
         strTestString = ""
       
         Strings = Split(cTest, "-")
       
         On Error GoTo leave
       
         For n = 0 To UBound(Strings)
             If IsNumeric(Trim(Strings(n))) Then
                 If IsDate(Trim(Strings(n)) & "-" & Trim(Strings(n + 1)) & "-" & Trim(Strings(n + 2))) Then
                     Exit For
                 Else
                     Exit Sub
                 End If
             End If
         Next n
       
         For m = 0 To UBound(Strings)
             If m = n Then strTestString = strTestString & Chr$(10)
             If m <> 0 Then strTestString = strTestString & "-"
             strTestString = strTestString & Strings(m)
         Next m
         cTest = strTestString
    Next cTest

leave:
    On Error GoTo 0

End Sub

Worked great. Thank you for the help

 

[pjmorris]

delighted it worked and many thanks for the feedback.