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

Question

编辑：@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. " & _
                    " (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

我正在尝试编写一个函数，将前导零插入到用户指定的列中。老实说，我希望它像 Excel 菜单数据 > 删除重复选项一样。我想单击一个菜单按钮，然后单击 select 我的范围并让它发挥作用，不幸的是，我在尝试推断已 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.  (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

让用户select一组小区接收程序。 InputBox method 似乎是一个额外的步骤，是工作流程的障碍。

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 中。有关详细信息，请参阅 Add Buttons to the Quick Access Toolbar and Customize Button Images。

Answer 2

我认为@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. " & _
                        " (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 3

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

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

Deducing column from User defined range in Excel VBA

excel

vba

excel-addins