vba code require to separate date from code

VBABEGINER

Well-known Member
Joined
Jun 15, 2011
Messages
1,284
Office Version
  1. 365
Platform
  1. Windows
Hi All,

I need a vba code, where I can split range value in code and date.

This are the values in Col A.
[TABLE="width: 150"]
<colgroup><col></colgroup><tbody>[TR]
[TD]CGU 002 - 05/89[/TD]
[/TR]
[TR]
[TD]ECG 21 501 - 05/00[/TD]
[/TR]
[TR]
[TD]ECG 21 762 - 04/14[/TD]
[/TR]
[TR]
[TD]CG 21 73 - 01/00[/TD]
[/TR]
[TR]
[TD]CG 21 06 - 05/14[/TD]
[/TR]
[TR]
[TD]CG 21 35 - 10/01[/TD]
[/TR]
[TR]
[TD]CG 21 47 - 12/07[/TD]
[/TR]
[TR]
[TD]CG 21 54 - 01/96[/TD]
[/TR]
[TR]
[TD]CG 21 55 - 09/99[/TD]
[/TR]
[TR]
[TD]CG 21 86 - 12/04[/TD]
[/TR]
[TR]
[TD]CG 21 96 - 03/05[/TD]
[/TR]
[TR]
[TD]CG 22 34 - 04/13[/TD]
[/TR]
[TR]
[TD]CG 22 43 - 04/13[TABLE="width: 150"]
<colgroup><col></colgroup><tbody>[TR]
[TD]CGU 002 - 05/89[/TD]
[/TR]
[TR]
[TD]ECG 21 501 - 05/00[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]

Here, "05/89" these are dates. I want, "CGU 002" these in A range and "05/89" these in B Col with addition of "05/01/89"..

Can some one pls help..
 
Give this revised macro a try (note I revised the comments for the changed parts of the code as was needed)...
[table="width: 500"]
[tr]
[td]
Code:
Sub SplitCodeDate()
  Dim R As Long, X As Long, Cnt As Long, Data As Variant
  ' Put all the data into an array so that the code does not keep
  ' asking the worksheet for data (arrays are much faster than
  ' continually referencing cells on the worksheet directly). Since
  ' there will be two columns of data outputted, I resize the single
  ' column of data to two columns in the array in order to output
  ' the correct size data at the end.
  Data = Range("B3", Cells(Rows.Count, "B").End(xlUp)).Resize(, 2)
  ' Examing the value in each cell
  For R = 1 To UBound(Data)
    ' Cnt is used to count digits in a cell's value, so we want
    ' it set to zero before each individual cell is examined.
    Cnt = 0
    ' While I assume Column C will be blank when I resized the range
    ' that I copied into the Data array originally, here I am making
    ' sure I did not accidentally pick up a value.
    Data(R, 2) = ""
    ' This loop starts at the end of the text from the cell's value
    ' being examined and iterates toward the beginning of the text.
    For X = Len(Data(R, 1)) To 1 Step -1
      ' If the digit count is less than 4 (remember, Cnt starts at 0),
      ' then we are still building the date value.
      If Cnt < 4 Then
        ' If the character being examined is a digit, then concatenate
        ' it into the second dimension of the Data array.
        If IsNumeric(Mid(Data(R, 1), X, 1)) Then
          ' Because we found a digit, increase the digit counter by one.
          Cnt = Cnt + 1
          ' Concatenate the digit on to the front of the digits that
          ' have already been found (remember, we are iterating backwards).
          Data(R, 2) = Mid(Data(R, 1), X, 1) & Data(R, 2)
        End If
        ' Once Cnt is equal to 4, that means we have found all of the digits
        ' that make up the date value.
      ElseIf Cnt = 4 Then
        ' We use VB's Format function to add the first day of the month to
        ' the date and place the slashes that the US date uses as its delimiter
        ' which is stored in the second dimension of the Data array.
        Data(R, 2) = Format(Data(R, 2), "@@/01/@@")
        ' We have found the date, so all the remaining text is placed in the
        ' first dimension of the Data array.
        Data(R, 1) = Trim(Left(Data(R, 1), X))
        ' We now remove any trailing dashes that may be left over
        If Right(Data(R, 1), 1) = "-" Then Data(R, 1) = Trim(Left(Data(R, 1), Len(Data(R, 1)) - 1))
        ' We are done with this cell so we end this loop and move onto the next one.
        Exit For
      End If
    Next
  Next
  ' Now that all of the text in all of the cells of Column B have be processed,
  ' then first we format the cells in Column D as a Date
  Range("D3").Resize(UBound(Data)).NumberFormat = "mm/dd/yyyy"
  ' then we place all of the data in Columns C and D (Column C gets the code,
  ' and Column D gets the date).
  Range("C3").Resize(UBound(Data), 2) = Data
End Sub
[/td]
[/tr]
[/table]
 
Upvote 0

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Super Macroman...Done Rick Sir...Ed is coming now..Hats off..


Give this revised macro a try (note I revised the comments for the changed parts of the code as was needed)...
[TABLE="width: 500"]
<tbody>[TR]
[TD]
Code:
Sub SplitCodeDate()
  Dim R As Long, X As Long, Cnt As Long, Data As Variant
  ' Put all the data into an array so that the code does not keep
  ' asking the worksheet for data (arrays are much faster than
  ' continually referencing cells on the worksheet directly). Since
  ' there will be two columns of data outputted, I resize the single
  ' column of data to two columns in the array in order to output
  ' the correct size data at the end.
  Data = Range("B3", Cells(Rows.Count, "B").End(xlUp)).Resize(, 2)
  ' Examing the value in each cell
  For R = 1 To UBound(Data)
    ' Cnt is used to count digits in a cell's value, so we want
    ' it set to zero before each individual cell is examined.
    Cnt = 0
    ' While I assume Column C will be blank when I resized the range
    ' that I copied into the Data array originally, here I am making
    ' sure I did not accidentally pick up a value.
    Data(R, 2) = ""
    ' This loop starts at the end of the text from the cell's value
    ' being examined and iterates toward the beginning of the text.
    For X = Len(Data(R, 1)) To 1 Step -1
      ' If the digit count is less than 4 (remember, Cnt starts at 0),
      ' then we are still building the date value.
      If Cnt < 4 Then
        ' If the character being examined is a digit, then concatenate
        ' it into the second dimension of the Data array.
        If IsNumeric(Mid(Data(R, 1), X, 1)) Then
          ' Because we found a digit, increase the digit counter by one.
          Cnt = Cnt + 1
          ' Concatenate the digit on to the front of the digits that
          ' have already been found (remember, we are iterating backwards).
          Data(R, 2) = Mid(Data(R, 1), X, 1) & Data(R, 2)
        End If
        ' Once Cnt is equal to 4, that means we have found all of the digits
        ' that make up the date value.
      ElseIf Cnt = 4 Then
        ' We use VB's Format function to add the first day of the month to
        ' the date and place the slashes that the US date uses as its delimiter
        ' which is stored in the second dimension of the Data array.
        Data(R, 2) = Format(Data(R, 2), "@@/01/@@")
        ' We have found the date, so all the remaining text is placed in the
        ' first dimension of the Data array.
        Data(R, 1) = Trim(Left(Data(R, 1), X))
        ' We now remove any trailing dashes that may be left over
        If Right(Data(R, 1), 1) = "-" Then Data(R, 1) = Trim(Left(Data(R, 1), Len(Data(R, 1)) - 1))
        ' We are done with this cell so we end this loop and move onto the next one.
        Exit For
      End If
    Next
  Next
  ' Now that all of the text in all of the cells of Column B have be processed,
  ' then first we format the cells in Column D as a Date
  Range("D3").Resize(UBound(Data)).NumberFormat = "mm/dd/yyyy"
  ' then we place all of the data in Columns C and D (Column C gets the code,
  ' and Column D gets the date).
  Range("C3").Resize(UBound(Data), 2) = Data
End Sub
[/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
Hi Rick Sir,
Sir, I need your help in one..I have applied for Ms Excel trainer in my team...and I want good and best knowledge on Pivot's and charts and overall Excel formula's...Could you able to give me something to refer...

Apart to this....With reference to this post...I have 2 more requirement...for that im sharing the entire code with you Sir...

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




Range("A2", Range("D500").End(xlDown)).Copy
Dim wb As Workbook
Set wb = Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A2").Select


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")
lRow = .Range("A2").End(xlDown).Row
For j = 2 To lRow
.Cells(j, "A").Value = WorksheetFunction.Proper(.Cells(j, "A").Value)
Next j
End With


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




Give this revised macro a try (note I revised the comments for the changed parts of the code as was needed)...
 
Upvote 0
Requirement is, at the end when I'm using
Proper function
, for some words, it should not apply...and these are fix..
Words are..
and, at, is, for, of, or
....These words should be in small letter...

2nd requirement now is like..where ever in Col A (Col A is Sentence)..

-where ever in Col A finds these words,
TRIA, TRIPRA, OFAC, PPACA, EBL, ERISA

These words should be in UPPER case only...

Can we do these changes Sir...

Sir, one more, if I want to share my excel file with you...how do I can share...

and Sir, please provide training material also....A really kind request Sir..







Give this revised macro a try (note I revised the comments for the changed parts of the code as was needed)...
 
Upvote 0
Hi Rick Sir,
Sir, I need your help in one..I have applied for Ms Excel trainer in my team...and I want good and best knowledge on Pivot's and charts and overall Excel formula's...Could you able to give me something to refer...
I am completely self-taught, so I am not the one to be able to advise you on this... for that, I would refer you to the impressive list of training links that hiker95 has posted in the past. Here is a link to what I believe is his latest posting...

https://www.mrexcel.com/forum/excel...e-template-excel-spreadsheet.html#post4972842



Apart to this....With reference to this post...I have 2 more requirement...for that im sharing the entire code with you Sir...
What exactly are those "2 more requirements"?

EDIT NOTE: I just saw your new message (#34) with the requirements in it (our messages crossed during posting)... let me look into it and get back to you.
 
Last edited:
Upvote 0
Sir, any luck on this...Or we will write code in another function and that we will call that is also ok...
The way which is more suitable..

I am completely self-taught, so I am not the one to be able to advise you on this... for that, I would refer you to the impressive list of training links that hiker95 has posted in the past. Here is a link to what I believe is his latest posting...

https://www.mrexcel.com/forum/excel...e-template-excel-spreadsheet.html#post4972842




What exactly are those "2 more requirements"?

EDIT NOTE: I just saw your new message (#34) with the requirements in it (our messages crossed during posting)... let me look into it and get back to you.
 
Upvote 0
Very Good Afternoon Rick Sir.. Kindly let me know sir, if anything can be done or possibility..Many Thanks..:)

I am completely self-taught, so I am not the one to be able to advise you on this... for that, I would refer you to the impressive list of training links that hiker95 has posted in the past. Here is a link to what I believe is his latest posting...
EDIT NOTE: I just saw your new message (#34) with the requirements in it (our messages crossed during posting)... let me look into it and get back to you.
 
Upvote 0
Dear Rick Sir, Im looking for your reply please...Guide me..what can i do in this case..



I am completely self-taught, so I am not the one to be able to advise you on this... for that, I would refer you to the impressive list of training links that hiker95 has posted in the past. Here is a link to what I believe is his latest posting...

https://www.mrexcel.com/forum/excel...e-template-excel-spreadsheet.html#post4972842




What exactly are those "2 more requirements"?

EDIT NOTE: I just saw your new message (#34) with the requirements in it (our messages crossed during posting)... let me look into it and get back to you.
 
Upvote 0
Dear Rick Sir,
Please have a look at the code once, and request you where ever it is possible ti minimize the code...please provide the changes with in expert manner of vba...Please...:bow:

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



I am completely self-taught, so I am not the one to be able to advise you on this... for that, I would refer you to the impressive list of training links that hiker95 has posted in the past. Here is a link to what I believe is his latest posting...

https://www.mrexcel.com/forum/excel...e-template-excel-spreadsheet.html#post4972842




What exactly are those "2 more requirements"?

EDIT NOTE: I just saw your new message (#34) with the requirements in it (our messages crossed during posting)... let me look into it and get back to you.
 
Upvote 0
I have question on this, please.
Please guide, what can be the solution..

I have some preposition's in my sentence..which are..
and, at, is, for, of, or

I want to keep them in small letter and rest other text in proper case...

I am showing my code..
Code:
'*Text Formating Proper, LowerCase, UpperCase
With Worksheets("Sheet1")
RowCnt2 = .Range("A3").End(xlDown).Row
For j = 3 To RowCnt2
    .Cells(j, "A").Value = WorksheetFunction.Proper(.Cells(j, "A").Value)
Next j
End With


With Worksheets("Sheet1")
RowCnt3 = .Range("A3").End(xlDown).Row
For l = 3 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

***As well as.....
I have some text with me, which I want them into in UPPER case only and rest other text in sentence in Proper case.

The words are..
TRIA, TRIPRA, OFAC, PPACA, EBL, ERISA

and code for this..
Code:
With Worksheets("Sheet1")
RowCnt4 = .Range("A3").End(xlDown).Row
For m = 3 To RowCnt4
    If Range("A" & m).Value Like "* tria *" Or Range("A" & m).Value Like "* tripra *" Or Range("A" & m).Value Like "* ofaca *" Or Range("A" & m).Value Like "* ppaca *" Or Range("A" & m).Value Like "* ebl *" Or Range("A" & m).Value Like "* erisa *" Or _
    Range("A" & m).Value Like "* tria" Or Range("A" & m).Value Like "* tripra" Or Range("A" & m).Value Like "* ofaca" Or Range("A" & m).Value Like "* ppaca" Or Range("A" & m).Value Like "* ebl" Or Range("A" & m).Value Like "* erisa" Or _
    Range("A" & m).Value Like "tria *" Or Range("A" & m).Value Like "tripra *" Or Range("A" & m).Value Like "ofaca *" Or Range("A" & m).Value Like "ppaca *" Or Range("A" & m).Value Like "ebl *" Or Range("A" & m).Value Like "erisa *" Then
    'If InStr(Cells(i, 9).Value, "LK") Then
    .Cells(m, "A").Value = UCase(.Cells(m, "A").Value)
    End If
Next m
End With
'*Text Formating Proper, LowerCase, UpperCase

but it making entire cell in lower & upper...

can any please help in code this..in correct format..My project is pending b'coz of this..
 
Last edited:
Upvote 0

Forum statistics

Threads
1,224,829
Messages
6,181,224
Members
453,025
Latest member
Hannah_Pham93

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top