在Excel VBA中从用户定义的范围中推导出列

编辑：@TimWilliams我编辑代码如下，但它现在不运行。 有什么想法吗？

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. " & _ " (eg 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 

我试图写一个函数，将插入前导零到用户指定的列。 老实说，我很喜欢这是像Excel菜单数据>删除重复选项。 我想点击一个菜单button，然后select我的范围，让它做的魔术，不幸的是，当我试图推断已被选中的列时，不断收到错误。 除了这个问题，它应该正常工作。 我的代码如下。 任何帮助将不胜感激！

 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. (eg 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有我认为正确的方法，但是因为你要求一个你原来的版本…

 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. " & _ " (eg 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

让用户select一组单元来接收程序。 一个InputBox方法似乎是一个额外的步骤，并阻碍工作stream程。

 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 

有了这一点，你应该没有任何困难将其添加到QAT。 请参阅将button添加到快速访问工具栏和自定义button图像以获取更多信息。

Answer 3

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