Convert selection to Leading zero format - excel

I am trying to build a simple macro that converts a selected range with numeric values to a "0000" format (e.g. 50,75,888, 1000 would be 0050,0075, 0888, 1000) i.e. it picks up each value in each cell and and returns a string value back to the sheet which can then be manipulated in Excel
Almost there (I think..) I just need help with the the $format function
Sub LeadingZero()
Dim RngSelected As Range
Dim R As String
Dim RCell As Range
Dim Rrng As Range
Dim RevNum As Long
On Error Resume Next
Set RngSelected = Application.InputBox("Please select a range of cells you want to convert to 0000 format", _
"SelectRng", Selection.Address, , , , , 8)
R = RngSelected.Address
Set Rrng = Range(R)
For Each RCell In Rrng.Cells
RCell.Value = Format$(RCell, "0000") 'this is the line I want to work!
'RCell.Value2 = Format$(RCell, "0000") doesn't seem to work either
Next RCell
End Sub
Thanks

Did you specifically want to do it with formatting? If you actually want to convert the value (useful for lookup and the like) then this function will do what you want.
Function FourDigitValues(InputString As String)
Dim X As Long, MyArr As Variant
MyArr = Split(InputString, ",")
For X = LBound(MyArr) To UBound(MyArr)
MyArr(X) = Right("0000" & MyArr(X), 4)
Next
FourDigitValues = Join(MyArr, ",")
End Function

Sub LeadingZero()
Dim RngSelected As Range
Dim R As String
Dim RCell As Range
Dim Rrng As Range
Dim RevNum As Long
On Error Resume Next
Set RngSelected = Application.InputBox("Please select a range of cells you want to convert to 0000 format", _
"SelectRng", Selection.Address, , , , , 8)
R = RngSelected.Address
Set Rrng = Range(R)
For Each RCell In Rrng.Cells
RCell.NumberFormat = "000#"
Next RCell
End Sub

Thanks to Assaf and Dan Donoghue:
Sub LeadingZero2()
'Takes a range with numbers between 1 and 9999 and changes them to text string with "0000" format
Dim RngSelected As Range
Dim RCell As Range
Dim Rrng As Range
On Error Resume Next
Set RngSelected = Application.InputBox("Please select a range of cells you want to convert to 0000 format", _
"SelectRng", Selection.Address, , , , , 8)
Set Rrng = Range(RngSelected.Address)
For Each RCell In Rrng.Cells
RCell.NumberFormat = "#"
RCell = CStr(Array("000", "00", "0")(Len(RCell) - 1) & RCell)
Next RCell
End Sub

Related

Excel VBA to split / format data vertically

I am trying to format and split a column of excel cells vertically. Each cell contains starts ICD-10: and then lots of codes separated with commas ",". I would like to Removed the ICD-10: and all of the spaces resulting in a column of just the individual codes. I found the following VBA code and have modified it to partly. I need to help removing the unwanted spaces and "ICD-10:" from the out put. I tried using trim and replace but I don't have a super firm understanding of exactly how this is working I just know it is close.
Any help is greatly appreciated.
Sub splitvertically()
'updatebyExtendoffice
Dim xRg As Range
Dim xOutRg As Range
Dim xCell As Range
Dim xTxt As String
Dim xStr As String
Dim xOutArr As Variant
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xOutRg = Application.InputBox("please select output cell:", "Kutools for Excel", , , , , , 8)
If xOutRg Is Nothing Then Exit Sub
For Each xCell In xRg
If xStr = "" Then
xStr = xCell.Value
Else
xStr = xStr & "," & xCell.Value
End If
Next
xOutArr = VBA.Split(xStr, ",")
xOutRg.Range("A1").Resize(UBound(xOutArr) + 1, 1) = Application.WorksheetFunction.Transpose(xOutArr)
End Sub
Sample Data
A1 = ICD-10: S7291XB, I4891, S0101XA, S7291XB, Z7901, V0300XA
A2 = ICD-10: S72431C, D62, E0590, E43, E785, E872, F321, G4700, I129, I2510, I441, I4891, I4892, I959, N183, R339, S0101XA, S01111A, S32591A, S7010XA, S72431C, Z6823, Z7901, Z87891, Y92481, S72351B
Thanks for the help.
You have a very good beginning. With only 3 more lines of code, we can make it happen. I don't know what happens then the output range xOutRg is more than one cell.
Option Explicit ' ALWAYS
Sub splitvertically()
'updatebyExtendoffice
Dim xRg As Range
Dim xOutRg As Range
Dim xCell As Range
Dim xTxt As String
Dim xStr As String
Dim xOutArr As Variant
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xOutRg = Application.InputBox("please select output cell:", "Kutools for Excel", , , , , , 8)
If xOutRg Is Nothing Then Exit Sub
For Each xCell In xRg
'just get the input value(s), then remove ICD-10, then remove any spaces
xTxt = xCell.Value
xTxt = Replace(xTxt, "ICD-10:", "")
xTxt = Replace(xTxt, " ", "")
' then append xTxt (not original cell)
If xStr = "" Then
xStr = xTxt
Else
xStr = xStr & "," & xTxt
End If
Next
xOutArr = VBA.Split(xStr, ",")
xOutRg.Range("A1").Resize(UBound(xOutArr) + 1, 1) = Application.WorksheetFunction.Transpose(xOutArr)
End Sub
Here's code that will split the cells in the way you describe. It works very fast but please take the time to read all the comments carefully. Some of them are just informative but others may require your action. In this regard, pay attention to the names I have given to the variables. A name like FirstDataRow will help you know what you should adjust.
Sub SplitCellsToList()
Const FirstDataRow As Long = 2 ' change to suit
Const InputColumn As Long = 1 ' change to suit (1 = column A)
Dim OutCell As Range ' first cell of output list
Dim InArr As Variant ' array of input values
Dim OutArr As Variant ' array of output values
Dim n As Long ' row index of OutArr
Dim Sp() As String ' Split cell value
Dim i As Integer ' index of Split
Dim R As Long ' loop counter: sheet rows
Set OutCell = Sheet1.Cells(2, "D") ' change to suit
With ActiveSheet
InArr = .Range(.Cells(FirstDataRow, InputColumn), _
.Cells(.Rows.Count, InputColumn).End(xlUp)).Value
End With
ReDim OutArr(1 To 5000) ' increase if required
' 5000 is a number intended to be larger by a significant margin
' than the total number of codes expected in the output
For R = 1 To UBound(InArr)
Sp = Split(InArr(R, 1), ":")
If UBound(Sp) Then
Sp = Split(Sp(1), ",")
For i = 0 To UBound(Sp)
Sp(i) = Trim(Sp(i))
If Len(Sp(i)) Then
n = n + 1
OutArr(n) = Sp(i)
End If
Next i
Else
' leave the string untreated if no colon is found in it
n = n + 1
OutArr(n) = InArr(R, 1)
End If
Next R
If n Then
ReDim Preserve OutArr(1 To n)
OutCell.Resize(n).Value = Application.Transpose(OutArr)
End If
End Sub

Loop through cells and display a message if a value is not found

I have a macro that loops through cells of one sheet, looks for that value in another sheet, and then highlights the row if they match. I'd like to add a message box that would pop up if a matching value is not found. I know this is a simple problem, but I'm having trouble figuring out in which loop to put my booleans.
Sub MarkXfer_noX()
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim j As Integer
Dim ProdCI As String
Dim found As Boolean
Dim intRowCount As Integer
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
For j = 2 To rng2.Rows.count 'from row 2 to the end
If rng2.Cells(j, 2) = ProdCI Then 'if the ProdCI in column B matches the one we picked,
Call FillCell(j) 'call a sub in a different module and give it our current row
found = True
Else
found = False
End If
Next
Next
If found = False Then
MsgBox (ProdCI & " not found") 'Display a message if one of the items wasn't found on the main page. Currently has an error where the last one in the list always pops up.
Else
End If
End Sub
Right now it always shows a msgbox with the last value in the range no matter what.
Thanks all, here is the updated working code using the Find function
Sub MarkXfer_Find()
'Re-tooled to use the .Find function instead of looping through each
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim ProdCI As String
Dim intRowCount As Integer
Dim intRowCount2 As Integer
Dim aCell As Range
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
intRowCount2 = Worksheets("All_ProCI").UsedRange.Rows.count
'use the Find function to put a value in aCell
Set aCell = rng2.Range("B1:B" & intRowCount2).Find(What:=ProdCI, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'MsgBox ProdCI & " found"
Call FillCell(aCell.row)
Else 'If aCell is blank display msgbox
MsgBox "ProdCI """ & ProdCI & """ not found"
End If
Next
End Sub

Match a value from the table to a dropdown range

I have been trying this for a while now and am not able to figure out the for code for this problem.
I have a table in sheet1 with two columns, in one column I have positions, in the next I have people who can work on those positions.
In sheet2 I have the list of all the positions and the one that are supposed to be staffed are highlighted when you select a SKU, and two columns besides it is the dropdown list of the employees.
This same sheet also has a range which displays employee who are not working that day.
Tried to implement #BruceWayne answer the code is:
Option Explicit
'use a constant to store the highlight color...
Const HIGHLIGHT_COLOR = 9894500 'RGB(100, 250, 150)
Sub AssignBided()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim cel1 As range
Dim cel2 As range
Dim line8 As range
Dim Offemp As range
Dim BidL8 As range
Dim BidL8E As range
Dim coresVal As String
Set ws1 = Worksheets("OT_Table")
Set ws2 = Worksheets("Monday")
Set line8 = ws2.range("Line8_Hilight_Mon")
Set Offemp = ws2.range("Off_Mon")
Set BidL8 = ws1.range("BidedL8")
Set BidL8E = ws1.range("BidedL8_E")
For Each cel2 In BidL8E
For Each cel1 In line8
If IsHighlighted(cel1) Then
If Application.WorksheetFunction.CountIf(Offemp, cel2.Value) > 0 Then
coresVal = Evaluate("Index(" & BidL8E.Address & "),MATCH(" & cel1.Validation & "," & BidL8.Address & ",0))")
Debug.Print coresVal
cel1.Offset(0, 2).Value = coresVal
End If
End If
Next cel1
Next cel2
End Sub
'Is a cell highlighted? EDIT: changed the function name to IsHighlighted
Function IsHighlighted(c As range)
IsHighlighted = (c.Interior.Color = HIGHLIGHT_COLOR)
End Function
This code is giving me this error: Object doesn't support this property or method. It highlights the evaluate line. Am I using this in some wrong manner?
From the comments, I think this is what you are trying to do.
(I renamed some variables to make them a little easier to understand. Also, adjust the named ranges as needed. They may not all be on the "OT_Table" sheet, which I assumed they were. It wasn't clear.)
Sub AssignBided()
Dim ws As Worksheet
Set ws = Worksheets("OT_Table")
Dim cel As Range
Dim line8 As Range
Set line8 = ws.Range("Line8_Highlight_Mon")
Dim Offemp As Range
Set Offemp = ws.Range("Scheduled_Off")
Dim BidL8 As Range
Set BidL8 = ws.Range("BidedL8_T")
Dim coresVal As String
For Each cel In line8
' cel.Select
If IsHighlighted(cel) Then
If Application.WorksheetFunction.CountIf(Offemp, cel.Value) > 0 Then
coresVal = Evaluate("INDEX(OFFSET(" & BidL8.Address & ",,2),MATCH(" & _
cel.Value & "," & BidL8.Address & ",0))")
Debug.Print coresVal
cel.Offset(0, 2).Value = coresVal
End If
End If
Next cel
End Sub

How to select columns through VBA when the columns selectin reference is: A,E,D,S

I'm requesting a parameter from the user to specify columns (in Excel) to select, but am having some issues with converting the value to a string that I can use in VBA for reference.
I'm trying to avoid having the user enter A:A,E:E,D:D,S:S and instead just enter A,E,D,S in a cell. I'm sure the answer is right there but at the moment it's escaping me. Any suggestions?
Like I said,
Split on the , and iterate through the resultant array and build the range:
Sub fooooo()
Dim str As String
Dim rng As Range
Dim strArr() As String
str = "A,E,D,S" 'you can change this to the cell reference you want.
strArr = Split(str, ",")
With Worksheets("Sheet1") ' change to your sheet
Set rng = .Range(strArr(0) & ":" & strArr(0))
For i = 1 To UBound(strArr)
Set rng = Union(rng, .Range(strArr(i) & ":" & strArr(i)))
Next i
End With
Debug.Print rng.Address
End Sub
You can always turn this into a Function that returns a range:
Function fooooo(str As String, ws As Worksheet) As Range
Dim rng As Range
Dim strArr() As String
strArr = Split(str, ",")
With ws ' change to your sheet
Set rng = .Range(strArr(0) & ":" & strArr(0))
For i = 1 To UBound(strArr)
Set rng = Union(rng, .Range(strArr(i) & ":" & strArr(i)))
Next i
End With
Set fooooo = rng
End Function
Then you would call it like this from any sub you need:
Sub foofind()
Dim rng As Range
Dim str As String
str = "A,E,D,S"
Set rng = fooooo(str, Worksheets("Sheet1"))
Debug.Print rng.Address

Using VBA to search for a text string in Excel

I'm trying to use VBA in a macro to search for a text string and delete the contents of the column. I previously found this on the website and would like to change it to search columns and delete the text "QA1" while retaining the columns. I hope this makes sense.
LastRow = Cells(Columns.Count, "D").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("D" & i).Value = "D" Then
Range("D" & i).EntireColumn.Delete
End If
Next i
You want to clear the contents of the whole column if one cell contains QA1?
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Columns(4)
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
.ClearContents
End If
End With
End Sub
If you want to just clear each instance of QA1 in column D:
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Columns(4)
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
Do
rCell.ClearContents
Set rCell = .FindNext(rCell)
Loop While Not rCell Is Nothing
End If
End With
End Sub
Can it be written to look through the entire worksheet and delete QA1
where ever it is found?
All instances of QA1 on sheet:
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Cells
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
Do
rCell.ClearContents
Set rCell = .FindNext(rCell)
Loop While Not rCell Is Nothing
End If
End With
End Sub
Edit: Add LookAt:=xlWhole to the Find arguments so it doesn't delete cells containing QA1 and other text (e.g. QA11 or Some text QA1)
This code goes through columns in a specified row and removes the "QA1" if found
Dim LastColumn As Integer
Dim RowNumber As Integer
Dim i As Integer
LastColumn = UsedRange.SpecialCells(xlCellTypeLastCell).Column
RowNumber = 1 'Adjust to your needs
For i = 1 To LastColumn Step 1
Cells(RowNumber, i).Value = Replace(Cells(RowNumber, i).Value, "QA1", "")
Next i
Loops through the used range of the active worksheet, and removes the selected text.
Sub RemoveText()
Dim c As Range
Dim removeStr As String
removeStr = InputBox("Please enter the text to remove")
For Each c In ActiveSheet.UsedRange
If c.Value = removeStr Then c.Delete
Next c
End Sub

Resources