vba code require to separate date from code

V

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]
Click to expand...

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..
 
Sort by date Sort by votes
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

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
Super Macroman...Done Rick Sir...Ed is coming now..Hats off..


Rick Rothstein said:
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]
Click to expand...
 
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
Click to expand...




Rick Rothstein said:
Give this revised macro a try (note I revised the comments for the changed parts of the code as was needed)...
Click to expand...
 
Upvote 0
Requirement is, at the end when I'm using
Proper function
Click to expand...
, for some words, it should not apply...and these are fix..
Words are..
and, at, is, for, of, or
Click to expand...
....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
Click to expand...

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..







Rick Rothstein said:
Give this revised macro a try (note I revised the comments for the changed parts of the code as was needed)...
Click to expand...
 
Upvote 0
VBABEGINER said:
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...
Click to expand...
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



VBABEGINER said:
Apart to this....With reference to this post...I have 2 more requirement...for that im sharing the entire code with you Sir...
Click to expand...
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..

Rick Rothstein said:
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.
Click to expand...
 
Upvote 0
Very Good Afternoon Rick Sir.. Kindly let me know sir, if anything can be done or possibility..Many Thanks..:)

Rick Rothstein said:
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.
Click to expand...
 
Upvote 0
Dear Rick Sir, Im looking for your reply please...Guide me..what can i do in this case..



Rick Rothstein said:
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.
Click to expand...
 
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
Click to expand...



Rick Rothstein said:
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.
Click to expand...
 
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
Click to expand...

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
Click to expand...

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
You must log in or register to reply here.

Similar threads

S
  • Solved
Formula to split date and time and work out energy usage trend
Replies
6
Views
460
Sundance_Kid
S
Dazzawm
  • Solved
Macro To Find Latest Date To Corresponding Data In Column B And Add To Sheet 2
Replies
7
Views
341
Fuji
F
sharky12345
  • Solved
Issue trying to identify earliest date & time
2
Replies
15
Views
529
sharky12345
sharky12345
J
  • Solved
Add 1 day to a date within a range as long as 2 conditions are met [without macros]
Replies
4
Views
820
juanam
J
K
  • Question Question
Excel Pivot table Time Values is not populating same as Source Sheet
Replies
1
Views
600
awoohaw
awoohaw

Forum statistics

Threads
1,223,912
Messages
6,175,339
Members
452,637
Latest member
Ezio2866

Share this page

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