如何使用Application.InputBox选择列？

时间：2013-08-14 16:31:50

标签： excel vba

如何使用InputBox选择单元格并使用该列的值？我修剪了大部分代码以使其适合，因此一些变量将是未声明的。

Sub MacroForTransfers（）

Application.ScreenUpdating = False
' Declare variables for sheet names and adding new sheet
SheetName1 = "Original"
SheetName2 = "New"
ActiveSheet.Name = SheetName1
Sheets.Add.Name = SheetName2
Sheets(SheetName2).Select
' End of declare variables for sheet names

Dim shipDate, truckRoute, ware, custPurchaseOrder, jobName, shipVia As String
Dim unitSelect As Range

shipVia = Application.InputBox(Prompt:="Please enter the ship via: ", Title:="Enter Ship Via", Default:="Enter two digit ship via here")
If shipVia = vbNullString Then
    Exit Sub
End If

shipDate = Application.InputBox(Prompt:="Please enter the date order needs to ship (e.g. 040113): ", Title:="Enter Ship Date", Default:="Enter six digit ship date here")
If shipDate = vbNullString Then
    Exit Sub
End If

custPurchaseOrder = Application.InputBox(Prompt:="Please enter customer PO#: ", Title:="Enter Customer PO#", Default:="Enter customer PO# here")
If custPurchaseOrder = vbNullString Then
    Exit Sub
End If

ware = Application.InputBox(Prompt:="Please enter warehouse to receive transfer: ", Title:="Enter Warehouse to Receive Transfer", Default:="Enter three digit warehouse code here")
If ware = vbNullString Then
    Exit Sub
End If

jobName = Application.InputBox(Prompt:="Please enter job name: ", Title:="Enter Job Name", Default:="Enter job name here")
If jobName = vbNullString Then
    Exit Sub
End If

truckRoute = Application.InputBox(Prompt:="Please enter the truck route: ", Title:="Enter Truck Route", Default:="Enter two digit truck route here")
If truckRoute = vbNullString Then
    Exit Sub
End If

Set unitSelect = Application.InputBox(Prompt:="Please enter the unit column: ", Type:=8)


Range("A1").Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""a300002"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[enter]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys " & Chr(34) & shipVia & Chr(34)
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys " & Chr(34) & shipDate & Chr(34)
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys " & Chr(34) & custPurchaseOrder & Chr(34)
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[down]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""man"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys " & Chr(34) & ware & Chr(34)
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[down]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[down]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[down]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[down]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[down]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[down]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[down]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys " & Chr(34) & jobName & Chr(34)
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[enter]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys " & Chr(34) & truckRoute & Chr(34)
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[enter]"""

Sheets(SheetName1).Select ' Select the Original Sheet
lastRow = 65536
For row = 3 To lastRow
    item = Range("A" & row).Value
    If item <> "" Then
        Transfer = Range("U" & row).Value
        unit = unitSelect.Parent.Cells(row, unitSelect.Column).Value
            If Transfer > 0 Then
            Sheets(SheetName2).Select ' Select the New Sheet
            lastRow = Cells(Rows.Count, "A").End(xlUp).row ' Find the last cell that has data in Column A
            Range("A" & lastRow).Select
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[backtab]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""man"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys " & Chr(34) & item & Chr(34)
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[up]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys " & Chr(34) & Transfer & Chr(34)
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[field+]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys " & Chr(34) & unit & Chr(34)
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[enter]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[tab]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""b"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[enter]"""
            ActiveCell.Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[enter]"""
            Sheets(SheetName1).Select ' Select the Original Sheet
        End If
    End If
Next row
Sheets(SheetName2).Select ' Select the New Sheet
lastRow = Cells(Rows.Count, "A").End(xlUp).row ' Find the last cell that has data in Column A
Range("A" & lastRow).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[pf7]"""
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "autECLSession.autECLPS.SendKeys ""[pf7]"""

End Sub

1 个答案:

答案 0 :(得分：0)

[编辑]：我已经修改了代码并对其进行了测试，它似乎成功地从所选列中提取：

Sub MacroForTransfers()

    Dim wsOld As Worksheet
    Dim wsNew As Worksheet
    Dim rngUnitSelect As Range
    Dim rngFound As Range
    Dim arrOutput() As String
    Dim strFirst As String
    Dim strShipVia As String
    Dim strCustPurchaseOrder As String
    Dim strJobName As String
    Dim strWare As String
    Dim strTruckRoute As String
    Dim lShipDate As Long
    Dim OutputIndex As Long

    strShipVia = Application.InputBox(Prompt:="Please enter the ship via: ", Title:="Enter Ship Via", Default:="Enter two digit ship via here", Type:=1)
    If Len(strShipVia) = 0 Then Exit Sub    'Pressed cancel

    lShipDate = Application.InputBox(Prompt:="Please enter the date order needs to ship (e.g. 040113): ", Title:="Enter Ship Date", Default:="Enter six digit ship date here", Type:=1)
    If lShipDate = 0 Then Exit Sub  'Pressed cancel

    strCustPurchaseOrder = Application.InputBox(Prompt:="Please enter customer PO#: ", Title:="Enter Customer PO#", Default:="Enter customer PO# here")
    If Len(strCustPurchaseOrder) = 0 Then Exit Sub  'Pressed cancel

    strWare = Application.InputBox(Prompt:="Please enter warehouse to receive transfer: ", Title:="Enter Warehouse to Receive Transfer", Default:="Enter three digit warehouse code here")
    If Len(strWare) = 0 Then Exit Sub   'Pressed cancel

    strJobName = Application.InputBox(Prompt:="Please enter job name: ", Title:="Enter Job Name", Default:="Enter job name here")
    If Len(strJobName) = 0 Then Exit Sub    'Pressed cancel

    strTruckRoute = Application.InputBox(Prompt:="Please enter the truck route: ", Title:="Enter Truck Route", Default:="Enter two digit truck route here")
    If Len(strTruckRoute) = 0 Then Exit Sub 'Pressed cancel

    On Error Resume Next    'Suppress error if user presses cancel
    Set rngUnitSelect = Application.InputBox(Prompt:="Please enter the unit column: ", Type:=8)
    On Error GoTo 0         'Remove the On Error Resume Next condition
    If rngUnitSelect Is Nothing Then Exit Sub   'Pressed cancel

    If Not Evaluate("IsRef(Original!A1)") Then ActiveSheet.Name = "Original"
    If Not Evaluate("IsRef(New!A1)") Then Sheets.Add.Name = "New"
    Set wsOld = Sheets("Original")
    Set wsNew = Sheets("New")
    wsNew.UsedRange.Clear

    wsNew.Range("A1:A24").Value = Application.Transpose(Array("autECLSession.autECLPS.SendKeys ""a300002""", "autECLSession.autECLPS.SendKeys ""[enter]""", _
                                                              "autECLSession.autECLPS.SendKeys " & Chr(34) & strShipVia & Chr(34), "autECLSession.autECLPS.SendKeys " & Chr(34) & lShipDate & Chr(34), _
                                                              "autECLSession.autECLPS.SendKeys ""[tab]""", "autECLSession.autECLPS.SendKeys " & Chr(34) & strCustPurchaseOrder & Chr(34), _
                                                              "autECLSession.autECLPS.SendKeys ""[down]""", "autECLSession.autECLPS.SendKeys ""[tab]""", _
                                                              "autECLSession.autECLPS.SendKeys ""man""", "autECLSession.autECLPS.SendKeys ""[tab]""", _
                                                              "autECLSession.autECLPS.SendKeys " & Chr(34) & strWare & Chr(34), "autECLSession.autECLPS.SendKeys ""[down]""", _
                                                              "autECLSession.autECLPS.SendKeys ""[down]""", "autECLSession.autECLPS.SendKeys ""[down]""", _
                                                              "autECLSession.autECLPS.SendKeys ""[down]""", "autECLSession.autECLPS.SendKeys ""[down]""", _
                                                              "autECLSession.autECLPS.SendKeys ""[down]""", "autECLSession.autECLPS.SendKeys ""[down]""", _
                                                              "autECLSession.autECLPS.SendKeys ""[tab]""", "autECLSession.autECLPS.SendKeys ""[tab]""", _
                                                              "autECLSession.autECLPS.SendKeys " & Chr(34) & strJobName & Chr(34), "autECLSession.autECLPS.SendKeys ""[enter]""", _
                                                              "autECLSession.autECLPS.SendKeys " & Chr(34) & strTruckRoute & Chr(34), "autECLSession.autECLPS.SendKeys ""[enter]""", _
                                                              "autECLSession.autECLPS.SendKeys ""[pf7]""", "autECLSession.autECLPS.SendKeys ""[pf7]"""))


    With wsOld.Range("A3:A" & Rows.Count)
        Set rngFound = .Find("*", wsOld.Cells(Rows.Count, "A"), xlValues, xlWhole)
        If Not rngFound Is Nothing Then
            ReDim arrOutput(1 To 21 * (.Rows.Count - WorksheetFunction.CountBlank(.Cells)))
            strFirst = rngFound.Address
            Do
                arrOutput(OutputIndex + 1) = "autECLSession.autECLPS.SendKeys ""[backtab]"""
                arrOutput(OutputIndex + 2) = "autECLSession.autECLPS.SendKeys ""man"""
                arrOutput(OutputIndex + 3) = "autECLSession.autECLPS.SendKeys " & Chr(34) & rngFound.Value & Chr(34)
                arrOutput(OutputIndex + 4) = "autECLSession.autECLPS.SendKeys ""[up]"""
                arrOutput(OutputIndex + 5) = "autECLSession.autECLPS.SendKeys ""[tab]"""
                arrOutput(OutputIndex + 6) = "autECLSession.autECLPS.SendKeys ""[tab]"""
                arrOutput(OutputIndex + 7) = "autECLSession.autECLPS.SendKeys ""[tab]"""
                arrOutput(OutputIndex + 8) = "autECLSession.autECLPS.SendKeys ""[tab]"""
                arrOutput(OutputIndex + 9) = "autECLSession.autECLPS.SendKeys ""[tab]"""
                arrOutput(OutputIndex + 10) = "autECLSession.autECLPS.SendKeys ""[tab]"""
                arrOutput(OutputIndex + 11) = "autECLSession.autECLPS.SendKeys " & Chr(34) & .Parent.Cells(rngFound.Row, "U").Value & Chr(34)
                arrOutput(OutputIndex + 12) = "autECLSession.autECLPS.SendKeys ""[field+]"""
                arrOutput(OutputIndex + 13) = "autECLSession.autECLPS.SendKeys " & Chr(34) & rngUnitSelect.Parent.Cells(rngFound.Row, rngUnitSelect.Column).Value & Chr(34)
                arrOutput(OutputIndex + 14) = "autECLSession.autECLPS.SendKeys ""[enter]"""
                arrOutput(OutputIndex + 15) = "autECLSession.autECLPS.SendKeys ""[tab]"""
                arrOutput(OutputIndex + 16) = "autECLSession.autECLPS.SendKeys ""[tab]"""
                arrOutput(OutputIndex + 17) = "autECLSession.autECLPS.SendKeys ""[tab]"""
                arrOutput(OutputIndex + 18) = "autECLSession.autECLPS.SendKeys ""[tab]"""
                arrOutput(OutputIndex + 19) = "autECLSession.autECLPS.SendKeys ""b"""
                arrOutput(OutputIndex + 20) = "autECLSession.autECLPS.SendKeys ""[enter]"""
                arrOutput(OutputIndex + 21) = "autECLSession.autECLPS.SendKeys ""[enter]"""
                OutputIndex = OutputIndex + 21
                Set rngFound = .Find("*", rngFound, xlValues, xlWhole)
            Loop While rngFound.Address <> strFirst
            .Parent.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(arrOutput)).Value = Application.Transpose(arrOutput)
        End If
    End With

End Sub
相关问题
最新问题