Deducing column from User defined range in Excel VBA - excel

Question

Edit: #TimWilliams I edited the code as follows but it it doesn't run at all now. ANy thoughts?
Sub Item_Fix()
Dim rng As Range, col As Range, arr
Dim sht As Worksheet, c As Range, tmp
On Error Resume Next 'in case user cancels
Set rng = Application.InputBox( _
Prompt:="Please select the Items to update. " & _
" (e.g. Column A or Column B)", _
Title:="Select Range", Type:=8)
On Error GoTo 0
' Set hdr = Application.InputBox( _
' Prompt:="Does your selection contain headers?", _
' Title:="Header Option")
hdr = MsgBox("Does your selection contain a header?", vbYesNo + vbQuestion, "Header Option")
If rng Is Nothing Then Exit Sub
If rng.Columns.Count > 1 Then
MsgBox "Please select only a single column!", vbExclamation
Exit Sub
End If
Set sht = rng.Parent
Set col = sht.Range(sht.Cells(2, rng.Column), _
sht.Cells(sht.Rows.Count, rng.Column).End(xlUp))
Application.ScreenUpdating = False
If hdr = vbYes Then
For Each c In col.Cells
tmp = Trim(c.Value)
If Len(tmp) > 0 And Len(tmp) < 9 And Row > 1 Then
c.NumberFormat = "#"
c.Value = Right("000000000" & tmp, 9)
End If
Next c
End If
If hdr = vbNo Then
For Each c In col.Cells
tmp = Trim(c.Value)
If Len(tmp) > 0 And Len(tmp) < 9 Then
c.NumberFormat = "#"
c.Value = Right("000000000" & tmp, 9)
End If
Next c
Application.ScreenUpdating = True
End If
End Sub
I'm trying to write a function that will insert leading zeroes into a column that a user specifies. Honestly, I would love for this to be like the Excel Menu Data > Remove Duplicates option. I want to click on a menu button and then select my range and let it do the magic, unfortunately I keep getting errors when trying to deduce the column that has been selected. Other than that issue, it should work fine. My code is below. Any help would be greatly appreciated!
Sub Item_Fix()
'Set Item = Application.InputBox("Select the range that contains the Items").Column
Set IC = Application.InputBox(Prompt:= _
"Please select the Range of Items. (e.g. Column A or Column B)", _
Title:="SPECIFY RANGE", Type:=8).Column
'Set Items = vRange.Column
Set Items = IC.Column
Lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Items.EntireColumn.Offset(0, 1).Insert
For i = 2 To Lastrow
Cells(i, Items + 1).Formula = "=Text(" & Cells(i, Items) & ",""000000000"")"
Next i
NewColumn = Items + 1
NewColumn.EntireColumn.Copy
Items.PasteSpecial xlPasteValues
NewColumn.EntireColumn.Delete
End Sub

Answer 1

#Jeeped has the right approach I think, but since you asked for a version of your original...
Sub Item_Fix()
Dim rng As Range, col As Range, arr
Dim sht As Worksheet, c As Range, tmp
On Error Resume Next 'in case user cancels
Set rng = Application.InputBox( _
Prompt:="Please select the Items to update. " & _
" (e.g. Column A or Column B)", _
Title:="Select Range", Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
If rng.Columns.Count > 1 Then
MsgBox "Please select only a single column!", vbExclamation
Exit Sub
End If
Set sht = rng.Parent
Set col = sht.Range(sht.Cells(2, rng.Column), _
sht.Cells(sht.Rows.Count, rng.Column).End(xlUp))
Application.ScreenUpdating = False
For Each c In col.Cells
tmp = Trim(c.Value)
If Len(tmp) > 0 And Len(tmp) < 9 Then
c.NumberFormat = "#"
c.Value = Right("000000000" & tmp, 9)
End If
Next c
Application.ScreenUpdating = True
End Sub

Answer 2

Let the user select a group of cells to receive the procedure. An InputBox method seems like one extra step and an impediment to the workflow.
Sub make_DUNS_number()
Dim duns As Range, tmp As String
For Each duns In Selection
'possible error control on non-numeric values
'if isnumeric(duns.value2) then
tmp = Right("000000000" & Format(duns.Value2, "000000000;#"), 9)
duns.NumberFormat = "#"
duns.Value2 = tmp
'end if
Next duns
End Sub
With that in place, you should have no trouble adding it to the QAT. See Add Buttons to the Quick Access Toolbar and Customize Button Images for more information.

Answer 3

Selection = Evaluate("index(text(" & Selection.Address & ",""'000000000""),,1)")