I have an sheet with column D where I have an ID in the format of
MG-456789 ; MG-Series ; MG-.
The above are the cases how the ID looks in my column D.
I would prefer to have an code, which works in such a way that, it checks for the number after MG - if there are 6 digits present, then it is valid, else I want it to be printed as invalid in column S.
For eg: if there is an ID like ; MG-Se then I want column S printed as invalid ; or MG- as invalid ; something like MG-456789 then its accepted and don't need to be printed in column S.
I tried to go through net and found Isnumeric can be used to check for the number in the cell. I could visualize for particular number but not a code for generic case like mine.
Can anyone help me how I can proceed with this case? any lead would be helpful.
Try this code.
Sub test()
Dim vDB, vR()
Dim Ws As Worksheet
Dim n As Long, i As Long, s As String
Set Ws = ActiveSheet
With Ws
vDB = .Range("d2", .Range("d" & Rows.Count).End(xlUp))
End With
n = UBound(vDB, 1)
ReDim vR(1 To n, 1 To 1)
For i = 1 To n
s = Replace(vDB(i, 1), "MG-", "")
If Len(s) = 6 And IsNumeric(s) Then
Else
vR(i, 1) = "false"
End If
Next i
Ws.Range("s2").Resize(n) = vR
End Sub
It's easy using Like operator:
If myString Like "MG-[0-9][0-9][0-9][0-9][0-9][0-9]" Then
MsgBox "Valid ID"
Else
MsgBox "Invalid ID"
End If
[0-9] stands for any digit, thus, it will match any string starting with MG- and followed by six digits.
You could also write it as a function to be called as
=CheckMG1(D2)
and pulled down
Function CheckMG1(s As String) As String
If Len(s) = 9 And Left(s, 3) = "MG-" And IsNumeric(Right(s, 6)) Then
CheckMG1 = "OK"
Else
CheckMG1 = "Invalid"
End If
End Function
A simpler code for you to try,
Sub MG()
Dim i As Long
For i = 1 To Cells(Rows.Count, "D").End(xlUp).Row
If IsNumeric(Replace(Cells(i, "D"), "MG-", "")) Then
Cells(i, "S") = "Valid"
Else
Cells(i, "S") = "InValid"
End If
Next i
End Sub
Related
I'm trying to look for values to create a final ticket number for a ticket reconciliation process. This is what should happen:
subroutine looks for a value in cell "Gx"
if it finds a value
pass value to function to strip out letters, convert to a number, pass back to subroutine to place in
cell "Ax"
if there is no value
pass value of "Cx" to function etc.
This loops through the number cells I have in my worksheet based on the number of rows filled in a separate column.
The function works fine by itself in the worksheet, but when I pass it a value from the subroutine column A fills up with the number of the row ie. A37=37, A8=8. I don't think I'm passing the argument correctly to the function, but I'm not certain. Here's the code for the subroutine and the function:
Sub final_ticket_number()
Dim rw As Integer
Dim i As Integer
'header label
Range("A1").Value = "Final Ticket #"
'set number of rows for loop
With Worksheets(1)
rw = .Range("B2").End(xlDown).Row
End With
'check col G for empty, use col C as backup
For i = 2 To rw
If Not IsEmpty(Cells(i, "G")) Then
'strip out letters in col G, place in col A
Cells(i, "A").Value = getNumeric("G" & i)
Else
'strip out letters in col C, place in col A
Cells(i, "A").Value = getNumeric("C" & i)
End If
Next i
End Sub
Function getNumeric(cellRef As String) As Long 'remove letters from ticket numbers
Dim stringLength As Integer
Dim i As Byte
Dim Result As String
stringLength = Len(cellRef)
'loops through each character in a cell to evaluate if number or not
For i = 1 To stringLength
If IsNumeric(Mid(cellRef, i, 1)) Then
Result = Result & Mid(cellRef, i, 1)
End If
Next i
'convert remaining characters to number
getNumeric = CLng(Result)
End Function
What am I missing?
As I understand it, the only thing that is wrong is your Len (cellRef), here you are only passing the range and not his value. See how I did it, I had to specify the spreadsheet, do the same that will work.
Use debug.print to see the outputs of the variables. Write in the code "debug.print XvariableX" and in the immediate check (Ctrl + G) you see the value assigned to the variable. good luck.
Sub final_ticket_number()
Dim rw As Integer
Dim i As Integer
Range("A1").Value = "Final Ticket #"
With Worksheets(1)
rw = .Range("B2").End(xlDown).Row
End With
For i = 2 To rw
If Not IsEmpty(Cells(i, "G")) Then
Cells(i, "A").Value = getNumeric("G" & i)
Else
Cells(i, "A").Value = getNumeric("C" & i)
End If
Next i
End Sub
Function getNumeric(cellRef As String) As Long 'remove letters from ticket numbers
Dim stringLength As Integer
Dim i As Byte
Dim Result As String
Dim Wrs As String
Wrk = ActiveWorkbook.Name
Workbooks(Wrk).Activate
Wrs = ActiveSheet.Name
stringLength = Len(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef))
For i = 1 To stringLength
If IsNumeric(Mid(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef), i, 1)) Then
Result = Result & Mid(Workbooks(Wrk).Worksheets(Wrs).Range(cellRef), i, 1)
End If
Next i
getNumeric = CLng(Result)
End Function
I have an Excel vba formula that pulls from database connection, fills out data in worksheet. This portion is working great!
What I need however is for one column(E) to be an alphanumeric indicator based on what data is in cell to to left(D). Example; if D=1-9 then E=1, D=10-99 then E=01, D=100-999 then E=001.
I found a piece of code by Sumit Bansal that seems like it should work.
Function AddLeadingZeroes(ref As Range, Length As Integer)
Dim i As Integer
Dim Result As String
Dim StrLen As Integer
StrLen = Len(ref)
For i = 1 To Length
If i <= StrLen Then
Result = Result & Mid(ref, i, 1)
Else
Result = "0" & Result
End If
Next i
AddLeadingZeroes = Result
End Function
Here is a portion of datadump into sheet, what I assume is wrong somehow I get type mismatch tried 1 with no quotes too. Something is off;
.Cells(intRow, 1).Value = "LockerTag.lwl"
.Cells(intRow, 2).Value = "3"
.Cells(intRow, 3).Value = rs("ID")
.Cells(intRow, 4).Value = rs("UnitQty")
.Cells(intRow, 5).Value = AddLeadingZeroes("1", StrLen(CStr(rs("UnitQty"))))
.Cells(intRow, 6).Value = rs("ID")
Any help would be greatly appreciated!
Log10 of the number (0-9, 10-99 etc.) gives number of leading zeroes.
Option Explicit
Sub test()
Debug.Print Log10(1)
Debug.Print Log10(10)
Debug.Print Log10(100)
Debug.Print Log10(1000)
End Sub
Private Function Log10(x)
Log10 = Log(x) / Log(10#)
End Function
Output:
0
1
2
3
JNevill suggestion worked perfect.
Dumped the function and swapped
.Cells(intRow, 5).Value = AddLeadingZeroes("1", StrLen(CStr(rs("UnitQty"))))
to
.Cells(intRow, 5).Value = String(Len(rs("UnitQty"))-1, "0") & "1"
Many thanks to everyone!
I'm currently struggling with the following problem
I'm trying to implement an input box where a user can input the character of the column.
After that, i dont know how to convert this into a number to use it in the Worksheet.Cells Method
For example: The User inputs "B", so the program saves it in a variable named x and converts it into a number so it can be used as Worksheet.Cells(Row, X)
Is there any method or does someone has an idea how to do this?
Cells() is your friend.
Don't overthink this.
Cells(1, 1) = "jello" ' changes cell A1
Cells(2, "AZ") = "too much jello" ' changes cell AZ2
The second argument of Cells() can be either a number or the alpha column header.
B is the second column, so you can use the expression (based on ASCII):
Sub main()
Dim s As String
s = "AB"
example s
End Sub
Sub example(s As String)
Dim colNum As Integer
Dim i As Integer
i = 1: colNum = 0
While (Mid(s, i, 1) <> "")
colNum = colNum * 26 + (Asc(UCase(Mid(s, i, 1))) - Asc("A") + 1)
i = i + 1
Wend
MsgBox colNum
End Sub
Function getColNum(colLetter As String) As Long
On Error Resume Next 'will return 0 if letter > last col
getColNum = Range(colLetter & "1").Column
End Function
I am trying to compare two columns and if any similar value is there then I want to print that value in a third column. My code is like this:
Sub compare()
Dim arr1 As Range
Dim arr2 As Range
Set arr1 = Range("A1:A6")
Set arr2 = Range("B1:B6")
For Each x In arr1
For Each y In arr2
If x = y Then
Cells(C1).Value = 0
End If
Next y
Next x
End Sub
I am seeing:
Run Time error 1004 Application-defined or object defined error
It is tricky to use For Each when working with an array as you don't know where is in your array the data you are trying to work with. And furthermore, it'll only create duplicate values and you won't be able to interact with your array directly.
Plus, as your loops were sets, you would compare each cell in the first array to each one in the second array. You only need a common factor to loop on.
I added a few tests to avoid some basic issues :
Sub compare()
Dim arr1 As Range, _
arr2 As Range, _
Ws As Worksheet
With Ws
Set arr1 = .Range("A1:A6")
Set arr2 = .Range("B1:B6")
If arr1.Columns.Count > 1 Or arr2.Columns.Count > 1 Then
MsgBox "Too many columns for this simple compare", vbCritical + vbOKOnly
Exit Sub
Else
If arr1.Rows.Count <> arr2.Rows.Count Or arr1.Cells(1, 1).Row <> arr2.Cells(1, 1).Row Then
MsgBox "The ranges don't have the same amout of lines or don't start at the same line", vbCritical + vbOKOnly
Exit Sub
Else
For i = 1 To arr1.Rows.Count
If arr1.Cells(i, 1) <> arr2.Cells(i, 1) Then
Else
.Cells(arr1.Cells(1, 1).Row + 1, _
Max(arr1.Cells(1, 1).Columns, arr2.Cells(1, 1).Column)) _
.Offset(0, 1).Value = arr1.Cells(i, 1)
End If
Next i
End If
End If
End With
End Sub
The short answer is that you need to specify Row and Column when using Cells. The column is 3 for column C so the code to display the matching values should have looked something like this:-
Sub compare()
Dim arr1 As Range
Dim arr2 As Range
Dim count As Integer
Set arr1 = Range("A1:A6")
Set arr2 = Range("B1:B6")
For Each x In arr1
For Each y In arr2
If x = y Then
count = count + 1
Cells(count, 3) = x
End If
Next y
Next x
End Sub
Below one easy way, define one array with one range with 3 columns (two to compare and the 3th to write result)
Sub compare()
Dim Arr() As Variant
Arr = Range("A1:C6")
Dim R As Long
For R = 1 To UBound(Arr, 1)
If Arr(R, 1) = Arr(R, 2) Then
Arr(R, 3) = 0 'or the value of 1th column like arr(r,1)
End If
Next R
Range("A1:C6") = Arr
End Sub
I have a spreadsheet of symbols and matching hex colors. I want to fill the cell itself (or the one next to it) with the hex color within the cell. I've read a bit about "conditional formatting", and I think that's the way to do it.
How might I achieve the result I would like?
Can't be achieved with Conditional Formatting for all colours.
Assuming: Row1 contains Data Labels, data set does not have gaps, the HEX colour is for the fill not the font, you have parsed the HEX colour values (numbers, not formulae) into Columns C:E (R,G,B) and that you do not require to do this often, then the ColourCells macro might suit:
Sub ColourCells()
Dim HowMany As Integer
On Error Resume Next
Application.DisplayAlerts = False
HowMany = Application.InputBox _
(Prompt:="Enter last row number.", Title:="To apply to how many rows?", Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
If HowMany = 0 Then
Exit Sub
Else
Dim i As Integer
For i = 2 To HowMany
Cells(i, 3).Interior.Color = RGB(Cells(i, 3), Cells(i, 4), Cells(i, 5))
Next i
End If
End Sub
and enter the value you want for n when prompted.
Sample output and formulae etc:
Excel's RGB() function actually creates a BGR value (I don't think anybody that might know why is saying why though) so Excel shows nibbles in reverse order. For the code Columns3,4,5 was logical but BGR rather than the conventional RGB in the image I thought might look odd. For F in the image the C3 value (the LEFT hand column of the 'RGB' three) is derived from applying RIGHT() to the Hex colour.
Minor edit to Jon Peltier's answer. His function ALMOST works, but the colors it renders are incorrect due to the fact the Excel will render as BGR rather than RGB. Here is the corrected function, which swaps the pairs of Hex values into the 'correct' order:
Sub ColorCellsByHex()
Dim rSelection As Range, rCell As Range, tHex As String
If TypeName(Selection) = "Range" Then
Set rSelection = Selection
For Each rCell In rSelection
tHex = Mid(rCell.Text, 6, 2) & Mid(rCell.Text, 4, 2) & Mid(rCell.Text, 2, 2)
rCell.Interior.Color = WorksheetFunction.Hex2Dec(tHex)
Next
End If
End Sub
Much simpler:
ActiveCell.Interior.Color = WorksheetFunction.Hex2Dec(Mid$(ActiveCell.Text, 2))
Mid strips off the leading "#", Hex2Dec turns the hex number into a decimal value that VBA can use.
So select the range to process, and run this:
Sub ColorCellsByHexInCells()
Dim rSelection As Range, rCell As Range
If TypeName(Selection) = "Range" Then
Set rSelection = Selection
For Each rCell In rSelection
rCell.Interior.Color = WorksheetFunction.Hex2Dec(Mid$(rCell.Text, 2))
Next
End If
End Sub
There is no need to repeatedly pierce the VBA/Worksheet barrier to convert. This streamlined version gets the byte order correct:
Sub ColorCellsByHex()
Dim r
If TypeName(Selection) <> "Range" Then Exit Sub
For Each r In Selection
r.Interior.Color = Abs(("&H" & Mid(r, 6, 2) & Mid(r, 4, 2) & Mid(r, 2, 2)))
Next
End Sub
This is another option - it updates the cell color when you select the cell assuming the value in the cell starts with "#" and is 7 characters.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (Left(ActiveCell.Text, 1) = "#" And Len(ActiveCell.Text) = 7) Then
ActiveCell.Interior.Color = WorksheetFunction.Hex2Dec(Mid$(ActiveCell.Text, 2))
End If
End Sub
For this, a userform can be made with the Hex2Dec function.
Function Hex2Dec(n1 As String) As Long
Dim nl1 As Long
Dim nGVal As Long
Dim nSteper As Long
Dim nCount As Long
Dim x As Long
Dim nVal As Long
Dim Stepit As Long
Dim hVal As String
nl1 = Len(n1)
nGVal = 0
nSteper = 16
nCount = 1
For x = nl1 To 1 Step -1
hVal = UCase(Mid$(n1, x, 1))
Select Case hVal
Case "A"
nVal = 10
Case "B"
nVal = 11
Case "C"
nVal = 12
Case "D"
nVal = 13
Case "E"
nVal = 14
Case "F"
nVal = 15
Case Else
nVal = Val(hVal)
End Select
Stepit = (nSteper ^ (nCount - 1))
nGVal = nGVal + nVal * Stepit
nCount = nCount + 1
Next x
Hex2Dec = nGVal
End Function
...
UserForm1.TextBox1 = "RGB(" & Hex2Dec(UserForm1.txtHex1.Value) & "," & _
Hex2Dec(UserForm1.txtHex2.Value) & "," & Hex2Dec(UserForm1.txtHex3.Value) & ")"
For example ;the entered value to textbox: #FF8800 - Result : RGB(255,136,0)