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!
Related
The script fills an array from a sheet called "Tigers" with 6 strings. Then it is supposed to compare that array to a differnt sheet titled "Elephants" and tell me if it finds an exact match. The troublesome code is found at the Application.Match method
Any help understanding how to correctly script a match with multiple values would be appreciated.
Sub matchData()
Dim arrCompare(5) As Variant
Dim intRow As Integer
Dim varRes As Variant
Set sht = ActiveSheet
Set shtTigers = Worksheets("Tigers").Range("A2:A100")
Set shtElephants = Worksheets("Elephants").Range("A2:A100")
Sheets("Elephants").Activate
For intRow = 2 To 100
arrCompare(0) = Worksheets("Elephants").Cells(intRow, 1).Value
arrCompare(1) = Worksheets("Elephants").Cells(intRow, 2).Value
arrCompare(2) = Worksheets("Elephants").Cells(intRow, 4).Value
arrCompare(3) = Worksheets("Elephants").Cells(intRow, 5).Value
arrCompare(4) = Worksheets("Elephants").Cells(intRow, 7).Value
arrCompare(5) = Worksheets("Elephants").Cells(intRow, 9).Value
'compare all 6 strings in array against Elephant sheet rows for a match
varRes = Application.Match(arrCompare(), shtTigers, 0)
'also tried
'varRes = Application.Match(((arrCompare(0))*((arrCompare(1))*((arrCompare(2)) * ((arrCompare(3)) * ((arrCompare(4)) * ((arrCompare(5))*((arrCompare(6)),shtTigers, 0)
'messagebox just gives a Error 13 or 2042 for varRes
MsgBox ("varRes = " & varRes)
Next
End Sub
Match requires a single lookup value but you're trying to pass the whole array. Iterate one element at at time instead:
Dim counter as Integer
For x = 0 to 5
If Not IsError(Application.Match(arrCompare(x), shtTigers, 0)) Then
counter = counter + 1
End If
Next x
If counter = 6 Then Debug.Print "Matches found"
I am trying to Index/Match data only when a certain criteria is met.
I could do this with two arrays but I'm hoping there's an easy answer here.
My code is as follows:
Sub Nozeroleftbehind(lengthRow As Integer)
For i = 2 To lengthRow
If Cells(1, i) = 0 Then Cells(1, i) = "TBD"
Next i
For i = 2 To lengthRow
If Cells(1, i) = "#N/A" Then
Cells(2, i) = "=INDEX(Forecast!L:L,MATCH('AA - Inbound Orders Weekly Rep'!H113,Forecast!A:A,0))"
End if
Next i
End Sub
And then pass that sub back to the main routine.
What I am trying to get dynamic is that 'H113' cell. I can't seem to get an offset to work properly since it's already in a formula.
EDIT: Apologies, H113 moves down. Next cell would be H114.
Regards
Please try this code.
Sub NoZeroLeftBehind(lengthRow As Integer)
' 18 Oct 2017
Dim lengthRow As Long
Dim Tmp As Variant
Dim C As Long
lengthRow = 4
For C = 2 To lengthRow
' bear in mind that the Cell is a Range
' and you want to refer to its Value & Formula property
With Cells(1, C)
Tmp = .Value
' using the Val() function will interpret a blank cell as zero value
If Val(Tmp) = 0 Then
.Value = "TBD"
ElseIf IsError(Tmp) Then
.Formula = "=INDEX(Forecast!L:L,MATCH('AA - Inbound Orders Weekly Rep'!H" & _
(113 + C - 2) & ",Forecast!A:A,0))"
End If
End With
Next C
End Sub
Knowing that you want to go H113, H114:
Cells(2, i) = "=INDEX(Forecast!L:L,MATCH('AA - Inbound Orders Weekly Rep'!H" & CStr(111 + i) & ",Forecast!A:A,0))"
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
First, thanks for reading and any help offered.
I'm basically clueless here. I've spent the last several days trying to figure out how to code what I'd like done, and I'll try to explain it clearly.
My workbook has multiple sheets, but only two of them are of interest regarding this: Schedule & Shift.
On Schedule, there are 17 columns and 40-100 rows containing the employees name (column A) in one column, their initials (B), their employee number (C), their shift (D) and shift hours (E - which is returned via vlookup to another sheet).
Basically, I want a button that will copy the data from each of those 5 columns to the Shift sheet starting at "A3" and continue to copy down the rows in Schedule until it reaches a blank field for their name (which is column A).
So far, I've managed to copy the first row and the second row with the following code:
Private Sub CommandButton1_Click()
Dim i As Integer, IntName As String, IntInit As String, IntID As Integer, Shift As String, Hours As Integer
Worksheets("Schedule").Select
i = 1
IntName = Range("a4")
IntInit = Range("b4")
IntID = Range("C4")
Shift = Range("D4")
Hours = Range("E4")
Do While i < 5
Worksheets("Shift").Select
Worksheets("Shift").Range("a2").Select
If Worksheets("Shift").Range("a2").Offset(1, 0) <> "" Then
Worksheets("Shift").Range("a2").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = IntName
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = IntInit
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = IntID
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Shift
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Hours
Worksheets("Schedule").Select
IntName = Worksheets("Schedule").Range("a4").Offset(1, 0)
IntInit = Worksheets("Schedule").Range("b4").Offset(1, 0)
IntID = Worksheets("Schedule").Range("c4").Offset(1, 0)
Shift = Worksheets("Schedule").Range("d4").Offset(1, 0)
Hours = Worksheets("Schedule").Range("e4").Offset(1, 0)
i = i + 1
Loop
End Sub
Obviously, this is clunky, and it doesn't actually do what I want beyond the 2nd time through the loop.
Any suggestions or pointers to help me move in the right direction?
Thanks again.
You're on the right path, you just need to nest our loop in another loop. Also, heed #BruceWayne's advice.
Private Sub CommandButton1_Click()
Dim i As Integer
Dim intCounter As Integer
Dim IntName As String
Dim IntInit As String
Dim IntID As Integer
Dim Shift As String
Dim Hours As Integer
'Adjust intCounter if you want to start on a row other than 1
intCounter = 1
Do
With Worksheets("Schedule")
IntName = .Cells(intCounter, 1).Value
IntInit = .Cells(intCounter, 2).Value
IntID = .Cells(intCounter, 3).Value
Shift = .Cells(intCounter, 4).Value
Hours = .Cells(intCounter, 5).Value
End With
If IntName = "" Then Exit Do
i = 1
Do While i < 5
'No need to use offset when you can just reference the cell directly.
'Also, not sure why you select this column anyhow.
'These lines can probably be deleted?
'If Worksheets("Shift").Range("a3").Value <> "" Then
' Worksheets("Shift").Range("a2").End(xlDown).Select
'End If
'Avoid using things like Select, ActiveCell, and ActiveSheet.
'What if someone clicks on something while your code is running?? Oops!
With Worksheets("Shift")
.Cells(i + 1, 2).Value = IntName
.Cells(i + 1, 3).Value = IntInit
.Cells(i + 1, 4).Value = IntID
.Cells(i + 1, 5).Value = Shift
.Cells(i + 1, 6).Value = Hours
End With
i = i + 1
Loop
'Increment to go to the next row of Schedule
intCounter = intCounter + 1
Loop
End Sub
brought in by Tim's concern about compact code, try this
Private Sub CommandButton1_Click()
With Worksheets("Schedule").Range("A4:E4").CurrentRegion
.Offset(1).Resize(.Rows.Count - 1).Copy Destination:=Worksheets("Shift").Range("A3")
End With
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)