Option Compare Text
Sub SplitFormDate()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim RowCnt1 As Integer
With Worksheets("Sheet1")
RowCnt1 = .Range("A3").End(xlDown).Row
For i = 3 To RowCnt1
.Cells(i, "A").Value = Trim(.Cells(i, "A").Value)
Next i
End With
Range("A3", Range("A3").End(xlDown)).Copy Range("AA3")
Range("AA3", Range("AA3").End(xlDown)).TextToColumns Destination:=Range("AA3"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), _
TrailingMinusNumbers:=True
Dim LastCol As Long, LastRow As Long
LastCol = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
LastRow = Cells(Rows.Count, "AA").End(xlUp).Row
Range("AA3", Cells(LastRow, LastCol)).Select
Selection.Copy
Range("AA3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Dim FndTxt As Range, zVal As Range, Fnd As Long
Set FndTxt = Range("AA3")
For Each zVal In Range("Z501", Range("Z" & Rows.Count).End(xlUp))
**** = WorksheetFunction.CountIf(Range("AA3", Cells(LastRow, LastCol)), zVal.Value)
If **** > 0 Then
For Fnd = 1 To ****
Set FndTxt = Range("AA3", Cells(LastRow, LastCol)).Find(What:=zVal.Value, After:=FndTxt, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Range("A" & FndTxt.Row).Interior.Color = vbGreen
Next Fnd
End If
Next zVal
Range(Cells(1, 27), Cells(1, LastCol)).EntireColumn.Delete Shift:=xlToLeft
Range("A2").Select
Dim MLst1 As Range
Application.ReplaceFormat.Clear
Application.ReplaceFormat.Interior.Color = vbGreen
For Each MLst1 In Range("List")
Columns("A").Replace "* " & MLst1 & " *", "", SearchFormat:=False, ReplaceFormat:=True
Next
Application.ReplaceFormat.Clear
Dim MLst2 As Range
Application.ReplaceFormat.Clear
Application.ReplaceFormat.Interior.Color = vbGreen
For Each MLst2 In Range("List")
Columns("A").Replace "* " & MLst2, "", SearchFormat:=False, ReplaceFormat:=True
Next
Application.ReplaceFormat.Clear
Dim R As Long, X As Long, Cnt As Long, Data As Variant
Data = Range("B3", Cells(Rows.Count, "B").End(xlUp)).Resize(, 2)
For R = 1 To UBound(Data)
Cnt = 0
Data(R, 2) = ""
For X = Len(Data(R, 1)) To 1 Step -1
If Cnt < 4 Then
If IsNumeric(Mid(Data(R, 1), X, 1)) Then
Cnt = Cnt + 1
Data(R, 2) = Mid(Data(R, 1), X, 1) & Data(R, 2)
End If
ElseIf Cnt = 4 Then
Data(R, 2) = Format(Data(R, 2), "@@/01/@@")
Data(R, 1) = Trim(Left(Data(R, 1), X))
If Right(Data(R, 1), 1) = "-" Then Data(R, 1) = Trim(Left(Data(R, 1), Len(Data(R, 1)) - 1))
Exit For
End If
Next
Next
Range("D3").Resize(UBound(Data)).NumberFormat = "mm/dd/yyyy"
Range("C3").Resize(UBound(Data), 2) = Data
Application.ReplaceFormat.Clear
Application.ReplaceFormat.Interior.Color = xlNone
Columns("A").Replace "* in *", "", SearchFormat:=False, ReplaceFormat:=True
Columns("A").Replace "* or *", "", SearchFormat:=False, ReplaceFormat:=True
Application.ReplaceFormat.Clear
Application.ReplaceFormat.Clear
Application.ReplaceFormat.Interior.Color = vbGreen
Columns("A").Replace "-*", "", SearchFormat:=False, ReplaceFormat:=True
Application.ReplaceFormat.Clear
With Worksheets("Sheet1")
RowCnt2 = .Range("A2").End(xlDown).Row
For j = 2 To RowCnt2
.Cells(j, "A").Value = WorksheetFunction.Proper(.Cells(j, "A").Value)
Next j
End With
With Worksheets("Sheet1")
RowCnt3 = .Range("A2").End(xlDown).Row
For l = 2 To RowCnt3
If Range("A" & l).Value Like "* and *" Or Range("A" & l).Value Like "* at *" Or Range("A" & l).Value Like "* is *" Or Range("A" & l).Value Like "* for *" Or Range("A" & l).Value Like "* of *" Or Range("A" & l).Value Like "* or *" Then
'If InStr(Cells(i, 9).Value, "LK") Then
.Cells(l, "A").Value = LCase(.Cells(l, "A").Value)
End If
Next l
End With
'copy in new workbook
Range("A2", Range("D500").End(xlDown)).Copy
Dim wb As Workbook
Set wb = Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A2").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Dim UsdRws As Long, k As Long
Application.ScreenUpdating = False
UsdRws = Range("A" & Rows.Count).End(xlUp).Row
For k = UsdRws To 2 Step -1
If Range("A" & k).Value Like "Exclusions" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "* Exclusions" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Exclusions *" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "* Exclusions *" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Excl" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "* Excl" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "Excl *" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
ElseIf Range("A" & k).Value Like "* Excl *" Then
Rows(k).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rows(k).Delete
End If
Next k
Application.ScreenUpdating = True
Range("A1:D1").Copy
Range("G1").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
ActiveSheet.UsedRange.Select
Selection.Copy
Sheets("sheet1").Select
Range("G2").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
ActiveSheet.UsedRange.Clear
Cells(1, 1).Select
Sheets("sheet1").Select
Columns("A:J").EntireColumn.AutoFit
Cells(1, 1).Select
End Sub