My VBA script is supposed to split content in one cell by line breaks into several rows, it works for some cells, date in one cell look like this:
a01gestmstrs2a 10.67.15.17
a01gestmdb2a 10.67.15.19
a01gstdbldnim1a
a01rstdbldnim1a
a01gestmstrs2b (10.67.15.46)
a01restmdb2a (10.67.15.48)
a01gestmstrs2z 10.67.15.20
a01gestmdb2b (10.67.15.47)
a01restmstrs2a (10.67.15.49)
However, it fails to split for some such as the sample provided above, I can't figure out why.
My code:
Sub SplitMultipleHostnames()
Dim tmpArr As Variant
Dim s As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each cell In Range("D2", Range("D3").End(xlDown))
For Each c In ActiveSheet.UsedRange
s = c.Value
If Trim(Application.Clean(s)) <> s Then
s = Trim(Application.Clean(s))
c.Value = s
End If
If cell.Value <> "" Then
If InStr(1, cell, Chr(10)) <> 0 Then
tmpArr = Split(cell, Chr(10))
cell.EntireRow.Copy
cell.Offset(1, 0).Resize(UBound(tmpArr), 1).EntireRow.Insert xlShiftDown
cell.Resize(UBound(tmpArr) + 1, 1) = Application.Transpose(tmpArr)
End If
Else
cell.EntireRow.Delete
cell.Row = cell.Row - 1
End If
Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.CutCopyMode = False
End Sub
The loop that uses Trim() and Clean() will remove all ASCII 10's and 13's from the worksheet.
There will be nothing to Split().
They are not actually Char(10) they are spaces. I changed the code to " " and it worked fine
If cell.Value <> "" Then
If InStr(1, cell, " ") <> 0 Then
tmpArr = Split(cell, " ")
Related
A strange question perhaps, but is there an alternative way of opening a workbook, searching for a particular reference in a column, and then pulling the data from a another column in that row using VBA, without using VLookup?
The table I am trying to get data from contains a mixture of numbers, text, dates, and the lookup value is often >13 digits long.
I sort of had something working with VLookup, but it was too inconsistent - every so often it would just break because the data type didn't match. An awful lot of 'type mismatch' or 'ByRef' errors - I'd get one right and then another breaks.
Unfortunately I don't know enough to know what to search to get me in the right direction.
If it helps explain what I'm trying to do, here's my code using VLookup that errors all the time:
Sub getData()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Dim wb As Workbook, src As Workbook
Dim srcRange As Range
Dim InputString
Dim strStatus
Dim strStatusNum
Dim strD1
Dim I As Integer
Set wb = ActiveWorkbook
I = 7
Set src = Workbooks.Open("D:\Files\test2.xlsx", True, True)
With src.Sheets(1)
Set srcRange = .Range(.Range("A1"), .Range("H1").End(xlDown))
End With
Do While wb.ActiveSheet.Cells(I, 1) <> ""
'Makes sure src.Close is called if errors
'On Error Resume Next
InputString = wb.Worksheets("Sheet 1").Cells(I, 1)
strStatus = Application.VLookup(InputString, srcRange, 3, False)
strD1 = Application.VLookup(InputString, srcRange, 4, False)
'Convert strStatus to actual number e.g. "03. no d1"
strStatusNum = Left(strStatus, 2)
wb.Worksheets("Sheet 1").Cells(I, 4) = strStatusNum
If (strStatusNum <> 3) Then
wb.Worksheets("Sheet 1").Cells(I, 2) = "Not at 03. No Work Order"
ElseIf (strStatusNum = 3) And (strD1 <> "") Then
wb.Worksheets("Sheet 1").Cells(I, 2) = "D1 Received"
wb.Worksheets("Sheet 1").Cells(I, 3) = strD1
Else
wb.Worksheets("Sheet 1").Cells(I, 2) = "No D1"
End If
I = I + 1
Loop
src.Close (False)
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub
EDIT: Corrected some syntax.
You can use the Find method of the Range object, in your case of the column. The return value is the first cell (represented as another Range object) with a matching value, unless there is no match at all. Then Nothing is returned.
On the returned (single cell) range you can use the EntireRow method to get a Range that represents all the cells on the row of the found cell. On the returned (row) range you can use the Cells method to select the cell matching the column in the same row, that you want to return (again represented as another Range object).
By the way, a more flexible alternative to VLOOKUP in workbook functions is a combination of INDEX and MATCH.
Untested but compiled:
Sub getData()
Dim src As Workbook
Dim srcRange As Range
Dim strStatus, strStatusNum, strD1
Dim m, rw As Range
Set rw = ActiveSheet.Rows(7)
Set src = Workbooks.Open("D:\Files\test2.xlsx", True, True)
With src.Sheets(1)
Set srcRange = .Range(.Range("A1"), .Range("H1").End(xlDown))
End With
Do While rw.Cells(1).Value <> ""
m = Application.Match(rw.Cells(1), srcRange.Columns(1), 0)
If Not IsError(m) Then 'proceed only if got match
strStatus = srcRange.Cells(m, 3).Value
strD1 = srcRange.Cells(m, 4).Value
strStatusNum = Left(strStatus, 2)
rw.Cells(4).Value = strStatusNum
If strStatusNum <> 3 Then
rw.Cells(2) = "Not at 03. No Work Order"
ElseIf strStatusNum = 3 And strD1 <> "" Then
rw.Cells(2) = "D1 Received"
rw.Cells(3) = strD1
Else
rw.Cells(2) = "No D1"
End If
End If
Set rw = rw.Offset(1, 0)
Loop
src.Close False
End Sub
you may be after this refactoring of your code
Sub getData()
Dim wbRng As Range, cell As Range, f As Range
Dim strStatus, strStatusNum, strD1
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
With ActiveWorkbook.ActiveSheet
Set wbRng = .Range("A7:A" & WorksheetFunction.Max(7, .Cells(.Rows.count, 1).End(xlUp).Row)) '<--| set the range of values to be searched for
If WorksheetFunction.CountA(wbRng) = 0 Then Exit Sub '<--| exit if no values under row 7
Set wbRng = wbRng.SpecialCells(xlCellTypeConstants) '<--| narrow the range of values to be searched for down to not blank values only
End With
With Workbooks.Open("D:\Files\test2.xlsx", True, True).Sheets(1) '<--| open wanted workbook and reference its first sheet
With .Range("A1:A" & .Cells(.Rows.count, "H").End(xlUp).Row) '<--| reference its column A range from row 1 down to column H last not empty cell (this is your former "srcRange")
For Each cell In wbRng.SpecialCells(xlCellTypeConstants) '<--| loop through range of values to be searched for
Set f = .Find(what:=cell.Value, lookat:=xlWhole, LookIn:=xlValues) '<--| look referenced range for current value to be searched for
If Not f Is Nothing Then '<--| if found
strStatus = f.Offset(, 2).Value
strD1 = f.Offset(, 3).Value
'Convert strStatus to actual number e.g. "03. no d1"
strStatusNum = val(Left(strStatus, 2)) '<--| use 'Val()' function to convert string "03" to "3"
cell.Offset(, 3) = strStatusNum
Select Case True
Case strStatusNum <> 3
cell.Offset(, 1).Value = "Not at 03. No Work Order"
Case strStatusNum = 3 And (strD1 <> "")
cell.Offset(, 1).Resize(, 2).Value = Array("D1 Received", strD1)
Case Else
cell.Offset(, 1).Value = "No D1"
End Select
End If
Next
End With
.Parent.Close False
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub
I have an Excel dataset that has a string in A1, and other values in B1, B2, and B3 that relate to A1; and so on down the page. Sometimes there are more than three cells that relate to the other string (unpredictable). In this example, cells A2 and A3 are blank. I want to create a macro that will fill A2 and A3 (etc) with the contents of A1.
In the example below I am using [] to help format it as Excel cells. I want to go from:
[SMITH, John] [Home]
[Mobile]
[Work]
[DOE, John] [Home]
[Mobile]
to
[SMITH, John] [Home]
[SMITH, John] [Mobile]
[SMITH, John] [Work]
[DOE, John] [Home]
[DOE, John] [Mobile]
I want the macro to repeat this for varying iterations, sometimes I have 1000 lines to adjust manually. Tweaking the software that outputs the data is not an option.
The code I have is as follows:
Sub rname()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
i = 0
While i < 50
If ActiveCell.Offset(1,0) = "" Then
ActiveCell.Offset(1,0) = cellvar
i = i + 1
ElseIf ActiveCell.Offset(1,0) = "*" Then
ActiveCell.Offset(1,0).Activate
i = i + 1
End If
Wend
End Sub
The above code adds text to the cell below the active cell once and then stops responding. The following code runs once and doesn't stop responding - I can run it again, but it doesn't automatically move down a row.
Sub repeat_name()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
i = 1
For i = 1 To 50
If ActiveCell.Offset(1, 0) = "" Then
ActiveCell.Offset(1, 0) = cellvar
End If
If ActiveCell.Offset(1, 0) = "*" Then
ActiveCell.Offset(1, 0).Select.Activate 'I have tried .Offset(2,0)too
End If
i = i + 1
Next
End Sub
I am stumped here. Does anyone have any thoughts or suggestions?
Try it as,
Sub fillBlanks()
With Worksheets("Sheet1")
With .Range(.Cells(2, "B"), .Cells(Rows.Count, "B").End(xlUp))
With .Offset(0, -1).SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
End With
With .Offset(0, -1)
.Value = .Value
End With
End With
End With
End Sub
Before fillBlanks procedure After fillBlanks procedure
Others have given working solutions, I'll just outline the problems with your code.
cellvar = ActiveCell assigns the value of the active cell to cellvar but cellvar won't change if ActiveCell changes so you'll just copy [SMITH, John] for all other people. You'd have to reassign cellvar.
If ActiveCell.Offset(1, 0) = "*" Then This checks if the cell contains an asterisk. Instead use Not ActiveCell.Offset(1, 0) = "", ActiveCell.Offset(1, 0) <> "", Not isEmpty(ActiveCell.Offset(1, 0)) or just Else (which would be the preferred version here since it doesn't require further calculations).
Edit: "*" Can be used as a wildcard with the Like operator as in If ActiveCell.Offset(1, 0) Like "*" Then but this would also be true for the empty string. To be sure that there is at least one sign you'd have to use "?*" instead. The question mark stands for exactly one character and the asterisk for 0 or more. To check if a cell is empty I would recommend one of the above ways though.
In you first sub this means that if the cell anything but "*", i will not be incremented and you end in an endless loop. In the second function, it means that the the active cell will not be changed and neither "" not "*" will be detected for the rest of the loop.
In the second sub, you don't need i=i+1, the for loop does that for you. This would mean that you increment i by 2 every iteration.
ActiveCell.Offset(1, 0).Select.Activate Here the "select" is too much
Here are the subs with minimal changes:
Sub rname()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
i = 0
While i < 50
If ActiveCell.Offset(1, 0) = "" Then
ActiveCell.Offset(1, 0) = cellvar
ActiveCell.Offset(1, 0).Activate 'the code will run without this but need to iterations per row
i = i + 1
MsgBox "a " & i
Else
ActiveCell.Offset(1, 0).Activate
cellvar = ActiveCell 'reassign cellvar
i = i + 1
MsgBox "b " & i
End If
Wend
End Sub
second sub:
Sub repeat_name()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
'i = 1 'this is not necessary
For i = 1 To 50
If ActiveCell.Offset(1, 0) = "" Then
ActiveCell.Offset(1, 0) = cellvar
End If
If Not ActiveCell.Offset(1, 0) = "" Then 'if else endif would be nicer here
ActiveCell.Offset(1, 0).Activate 'remove "select"
cellvar = ActiveCell 'reassign cellvar
End If
'i = i + 1 'this is not necessary/wrong
Next i 'safer to include i
End Sub
Note that this is just to explain the problems with your code, I still recommend to use one of the other solutions here.
Try this:
Sub repeat_name()
Dim cellvar As String
Dim i As Integer
Dim ws As Worksheet
Set ws = Sheet1 'Change according to your sheet number
cellvar = ""
For i = 1 To 50
if Trim(ws.Range("A" & i )) <> "" then
cellvar = Trim(ws.Range("A" & i ))
Else
ws.Range("A" & i ) = cellvar
End if
Next i
End Sub
How about this:
Sub FillBlanks()
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
End Sub
try this:
Sub repeat_name()
Dim k As Integer
Dim i As Integer
i = 1
k = ActiveSheet.UsedRange.Rows.Count
While i <= k
With ActiveSheet
If .Range("A1").Value = "" Then
MsgBox "Error: First cell can not be empty."
Exit Sub
End If
If .Range("A" & i).Value = "" And .Range("B" & i).Value <> "" Then
.Range("A" & i).Value = .Range("A" & i - 1).Value
End If
End With
i = i + 1
Wend
End Sub
try this
Sub test()
lastrow = Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Cells(i, 1) = "" Then
Cells(i, 1) = Cells(i - 1, 1)
End If
Next i
End Sub
Screen shot of what I want:
I want to time stamp each line as a change gets made so I can upload to a central file all lines that have been updated after a certain time. Since one asset might have multiple rows for each sub component, the user can fill in one line and autofill/copy paste to the relevant lines beneath. The rows might not be in a continuous range (e.g. when filtered).
The code I've got works great for changing one cell at a time and it works for a range but incredibly slowly.
This sub is called by worksheet_change shown in full below.
Sub SetDateRow(Target As Range, Col As String)
Dim TargetRng As Range
Dim LastCol, LastInputCol As Integer
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
End With
For Each TargetRng In Target.Cells
If TargetRng.Cells.Count > 1 Then
Application.EnableEvents = True
Exit Sub
Else
Application.EnableEvents = False
Cells(TargetRng.Row, LastCol - 2) = Now()
Cells(TargetRng.Row, LastCol - 1).Value = Environ("username")
Cells(TargetRng.Row, LastCol).Value = Target.Address
End If
Next
Application.EnableEvents = True
End Sub
Target.Cells.Address returns the range (including non-visible cells), but I can't work out how to split this into individual, visible cells that I can loop through.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Errorcatch
Dim TargetRng As Range
Dim LastCol, LastInputCol, LastRow As Integer
Dim LastInputColLetter As String
Dim ContinueNewRow
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
LastInputCol = LastCol - 3
If LastInputCol > 26 Then
LastInputColLetter = Chr(Int((LastInputCol - 1) / 26) + 64) & Chr(((LastInputCol - 1) Mod 26) + 65)
Else
LastInputColLetter = Chr(LastInputCol + 64)
End If
For Each TargetRng In Target.Cells
If TargetRng.Row <= 2 Then
Exit Sub
End If
If TargetRng.Column <= LastInputCol Then
SetDateRow Target, LastCol - 3
If TargetRng.Count = 1 Then
Application.EnableEvents = False
'
Dim cmt As String
' If Target.Value = "" Then
' Target.Value = " "
'
' End If
'----------------------------------------------------------------
If Intersect(TargetRng, Range("AC3:AC10000")) Is Nothing Then ' need to make column into variables in the code based on column name
Application.EnableEvents = True
Else
Application.EnableEvents = False
Cells(TargetRng.Row, "Z") = Now() 'Date booking was made column
Cells(TargetRng.Row, "AD").Value = Cells(Target.Row, "AD").Value + 1 ' iteration column
End If
'----------------------------------------------------------------
If TargetRng.Comment Is Nothing Then
cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "*"
Else
cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "* " & TargetRng.Comment.Text
End If
With TargetRng
.ClearComments
.AddComment cmt
End With
End If
End If
Application.EnableEvents = True
Next
Exit Sub
Errorcatch:
MsgBox Err.Description
Application.EnableEvents = True
End Sub
I have done some adjustments to your code (see comments within code)
This solution assumes the following:
Sample data has a two rows header and fields to be updated have the following titles located at row 1 (adjust corresponding lines in code if needed):
Date Change Made, Who Made Change and Last Cell Changed as per picture provided.
Booked Date, BkdDte Change and Iteration for columns AC, Z and AD respectively (this names are used for testing purposes, change code to actual names)
I have also combined both procedures into a common one in order to avoid the inefficient approach of looping twice the cells of the changed range. Let me know if they must remain separated and will do the necessary adjustments.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Wsh As Worksheet, rCll As Range
Dim iDteChn As Integer, iWhoChn As Integer, iLstCll As Integer
Dim iBkdDte As Integer, iBkdChn As Integer, iBkdCnt As Integer
Dim sCllCmt As String
Dim lRow As Long
On Error GoTo ErrorCatch
Rem Set Application Properties
Application.ScreenUpdating = False 'Improve performance
Application.EnableEvents = False 'Disable events at the begining
Rem Set Field Position - This will always returns Fields position
Set Wsh = Target.Worksheet
With Wsh
iDteChn = WorksheetFunction.Match("Date Change Made", .Rows(1), 0)
iWhoChn = WorksheetFunction.Match("Who Made Change", .Rows(1), 0)
iLstCll = WorksheetFunction.Match("Last Cell Changed", .Rows(1), 0)
iBkdDte = WorksheetFunction.Match("Booked Date", .Rows(1), 0) 'Column of field "Booked date" (i.e. Column `AC`)
iBkdChn = WorksheetFunction.Match("BkdDte Change", .Rows(1), 0) 'Column of field "Booked date changed" (i.e. Column `Z`)
iBkdCnt = WorksheetFunction.Match("Iteration", .Rows(1), 0) 'Column of field "Iteration" (i.e. Column `AD`)
End With
Rem Process Cells Changed
For Each rCll In Target.Cells
With rCll
lRow = .Row
Rem Exclude Header Rows
If lRow <= 2 Then GoTo NEXT_Cll
Rem Validate Field Changed
Select Case .Column
Case Is >= iLstCll: GoTo NEXT_Cll
Case iDteChn, iWhoChn, iBkdChn, iBkdCnt: GoTo NEXT_Cll
Case iBkdDte
Rem Booked Date - Set Count
Wsh.Cells(lRow, iBkdChn) = Now()
Wsh.Cells(lRow, iBkdCnt).Value = Cells(.Row, iBkdCnt).Value + 1
End Select
Rem Update Cell Change Details
Wsh.Cells(lRow, iDteChn).Value = Now()
Wsh.Cells(lRow, iWhoChn).Value = Environ("username")
Wsh.Cells(lRow, iLstCll).Value = .Address
Rem Update Cell Change Comments
sCllCmt = Now & vbCrLf & Environ("UserName") & " *" & .Value & "*"
If Not .Comment Is Nothing Then sCllCmt = sCllCmt & .Comment.Text
.ClearComments
.AddComment sCllCmt
End With
NEXT_Cll:
Next
Rem Restate Application Properties
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrorCatch:
MsgBox Err.Description
Rem Restate Application Properties
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Do let me know of any questions you might have about the resources used in this procedure.
You could use something like this:
Sub SetDateRow(Target As Range, Col As String)
Dim TargetRng As Range
Dim LastCol As Long
Dim LastInputCol As Long
Dim bEvents As Boolean
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
End With
bEvents = Application.EnableEvents
Application.EnableEvents = False
If Target.Cells.Count > 1 Then
For Each TargetRng In Target.SpecialCells(xlCellTypeVisible).Areas
Cells(TargetRng.Row, LastCol - 2).Resize(TargetRng.Rows.Count, 1).Value = Now()
Cells(TargetRng.Row, LastCol - 1).Resize(TargetRng.Rows.Count, 1).Value = Environ("username")
Cells(TargetRng.Row, LastCol).Resize(TargetRng.Rows.Count, 1).Value = Target.Address
Next
Else
Cells(Target.Row, LastCol - 2).Value = Now()
Cells(Target.Row, LastCol - 1).Value = Environ("username")
Cells(Target.Row, LastCol).Value = Target.Address
End If
Application.EnableEvents = bEvents
End Sub
but make sure you call it before or after the loop in your change event, not inside it as you are now!
I have:
nuid="!,#,a-z"
But I do not want the double quotes. I want nuid=!,#,a-z
Suggest me ways to remove the start and end quotes
Here is my code:
sub highlight(nuid as string)
dim sh3 as worksheet
Set sh3 = Thisworkbook.Worksheets("Sheet1")
sh3.Select
Cells.Find("User ID").Select
ActiveCell.Offset(1, 0).Select
nuid = Replace(nuid, """", "")
Set rn = sh3.UsedRange
k = rn.Rows.Count + rn.Row - 1
For x = 1 To k
If ActiveCell.Value Like nuid Then
Selection.Interior.Color = vbYellow
Else
Selection.Interior.ColorIndex = xlNone
End If
ActiveCell.Offset(1, 0).Select 'moves activecell down one row.
Next
end sub
From my gui, i will enter special characters which will be stored in the variable nuid.I want only the special characters and not the quotes around it
Also you can try:
nuid = Replace(nuid, Chr(34), vbNullString)
But you can have problem if quotes not the first nor the last character, for example: "!,#,"a-z".
In that case you can try:
nuid = Mid(nuid, 2, Len(nuid) - 1) This will cut the first and last character
Edit:
It seems to me that the quotes that you see indicates the type of a variable string.
Edit2 - watch window
Results:
Edit3 - with sub 4 Sagi:
Sub Highlight4Sagi(SpecChar As String)
Dim Column As Integer
SpecChar = "!##"
ThisWorkbook.Worksheets(1).Select
Column = Cells.Find("User ID").Column
LastRow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For i = 2 To LastRow 'loop each row in column "User ID"
For j = 1 To Len(SpecChar) 'loop every specchar: ! and # and # and find him in each cells
If InStr(1, Cells(i, Column), Mid(SpecChar, j, 1)) > 0 Then
Cells(i, Column).Interior.ColorIndex = 6
Exit For
Else
Cells(i, Column).Interior.ColorIndex = 0
End If
Next j
Next i
End Sub
Proper Function:
Sub Test()
Debug.Print RemoveOuterQuotes(Cells(2, 1).Value)
End Sub
Public Function RemoveOuterQuotes(ByVal Str As String) As String
If Left(Str, 1) = """" Then
Str = Right(Str, Len(Str) - 1)
End If
If Right(Str, 1) = """" Then
Str = Left(Str, Len(Str) - 1)
End If
'Debug.Print Str
'Stop
RemoveOuterQuotes = Str
End Function
Basically escape a " with ""
Below should help
nuid = replace (nuid, """", "")
additional variant
Sub highlight(nuid As String)
Dim sh3 As Worksheet, Cl&, Lrow&, x&, oCell As Range
Set sh3 = ThisWorkbook.Worksheets("Sheet1")
Cl = sh3.Cells.Find("User ID").Column
Frow = sh3.Cells.Find("User ID").Row + 1
Lrow = Cells.Find("*", , , , xlByRows, xlPrevious).Row
For Each oCell In sh3.Range(Cells(Frow, Cl), Cells(Lrow, Cl))
If oCell.Value <> "" Then
For x = 1 To Len(nuid)
If oCell.Value Like "*" & Mid(nuid, x, 1) & "*" Then
oCell.Interior.Color = vbYellow
Exit For
Else
oCell.Interior.Color = xlNone
End If
Next x
End If
Next oCell
End Sub
output
but if you need to find, for instance the cells which contain any char in low case [a-z] then another aproach should be used
I am new to Excel VBA and I really need your help. I have a code that will look for the duplicate values in Column A. This code will highlight the duplicate values. I want:
1.) This code to ONLY run when I click on a button.
2.) I would like to have (somewhere in the same worksheet), the number of duplicate results and a hyper link that when you click on it will direct you the duplicate result (this is because I have sometimes huge files that I need to validate). Here is the code I currently have:
Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim C As Range, i As Long
If Not Intersect(Target, Me.[A:A]) Is Nothing Then
Application.EnableEvents = False
For Each C In Target
If C.Column = 1 And C.Value > "" Then
If WorksheetFunction.CountIf(Me.[A:A], C.Value) > 1 Then
i = C.Interior.ColorIndex
f = C.Font.ColorIndex
C.Interior.ColorIndex = 3 ' Red
C.Font.ColorIndex = 6 ' Yellow
C.Select
MsgBox "Duplicate Entry !", vbCritical, "Error"
C.Interior.ColorIndex = i
C.Font.ColorIndex = f
End If
End If
Next
Application.EnableEvents = True
End If
End Sub
I would really appreciate it if you help me with this.
Add the code to Module1 Alt+F11
Option Explicit
Sub MyButton()
Dim RangeCell As Range, _
MyData As Range
Dim MyDupList As String
Dim intMyCounter As Integer
Dim MyUniqueList As Object
Dim lngLastRow As Long, lngLoopRow As Long
Dim lngWriteRow As Long
Set MyData = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set MyUniqueList = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
MyDupList = "": intMyCounter = 0
'// Find Duplicate
For Each RangeCell In MyData
If RangeCell <> "V" And RangeCell <> "R" Then
If Evaluate("COUNTIF(" & MyData.Address & "," & RangeCell.Address & ")") > 1 Then
'// Color. Change to suit RGB(141, 180, 226).
RangeCell.Interior.Color = RGB(141, 255, 226)
If MyUniqueList.exists(CStr(RangeCell)) = False Then
intMyCounter = intMyCounter + 1
MyUniqueList.Add CStr(RangeCell), intMyCounter
If MyDupList = "" Then
MyDupList = RangeCell
Else
MyDupList = MyDupList & vbNewLine & RangeCell
End If
End If
Else
RangeCell.Interior.ColorIndex = xlNone
End If
End If
Next RangeCell
'// Move duplicate from Column 1 to Column 7 = (G:G)
lngWriteRow = 1
lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For lngLoopRow = lngLastRow To 1 Step -1
With Cells(lngLoopRow, 1)
If WorksheetFunction.CountIf(Range("A1:A" & lngLastRow), .Value) > 1 Then
If Range("G:G").Find(.Value, lookat:=xlWhole) Is Nothing Then
Cells(lngWriteRow, 7) = .Value
lngWriteRow = lngWriteRow + 1
End If
End If
End With
Next lngLoopRow
Set MyData = Nothing: Set MyUniqueList = Nothing
Application.ScreenUpdating = False
If MyDupList <> "" Then
MsgBox "Duplicate entries have been found:" & vbNewLine & MyDupList
Else
MsgBox "There were no duplicates found in " & MyData.Address
End If
End Sub
.
Add Module
Add Button
Assign to Macro