简体   繁体   English

将用户表单输入转移到单元格区域

[英]Transfer Userform input to range of cells

I felt like I had to ask help from experts as I've been losing quite a lot of time trying to figure this out without much success. 我觉得我不得不寻求专家的帮助,因为我已经浪费了很多时间试图解决这个问题,但没有取得太大的成功。

I'm in the midst of building a simple database where users will have to enter values based on drop-down menus. 我正在构建一个简单的数据库,在该数据库中,用户将必须基于下拉菜单输入值。 The exception to that is, column AB which contains a userform in which the operator will have to enter two numerical values ie "Minor findings" & "Major findings", both ranging from 1 to 25. 唯一的例外是AB列 ,其中包含一个用户表单,操作员必须在其中输入两个数值,即“次要发现”和“主要发现”,均介于1到25之间。

Currently, the userform is automatically triggered as soon as the user selects a specific range of cells AB14:AB200 当前,一旦用户选择了特定范围的单元格AB14:AB200 ,就会自动触发用户窗体

The user then presses a button entitled caclculate severity which is supposed to then transpose the two values onto the two columns AI & AJ 然后,用户按下标题为“ 计算严重性”的按钮,然后将其转换为两个值AIAJ

The issue I'm facing is the following: The user can trigger the userform from cell AB56 , enter the two values, press calculare severity , but the output will always be transposed onto the first rows of the range (AI14 & AJ14) instead of (AI56 & AJ56). 我面临的问题如下:用户可以从AB56单元格触发用户窗体 ,输入两个值,按calculare严重性 ,但是输出将始终转置到范围的第一行(AI14和AJ14),而不是(AI56和AJ56)。

I've attached a sample of my code along with a screenshot of the database. 我已经附上了我的代码示例以及数据库的屏幕截图。

数据库屏幕快照

Private Sub Calculateseveritybutton_Click()

Worksheets("International CCU Tracker").Activate
Set xrg = Worksheets("International CCU Tracker").Range("AB14:AB200")

For Each xcell In xrg

' replace the sheet name and range A2 or B2 with yours
If Textbox1.Value = "0-25" And Textbox2.Value = "0-25" Then
MsgBox ("Please enter a Minor and Major finding value")

ElseIf Textbox1.Value <> "0-25" And Textbox2.Value = "0-25" Then
Sheets("International ccu tracker").Range("AI" & xcell.Row).Value = Textbox1.Value
MsgBox ("Please enter a Major finding value")

ElseIf Textbox1.Value = "0-25" And Textbox2.Value <> "0-25" Then
Sheets("International ccu tracker").Range("AJ" & xcell.Row).Value = Textbox2.Value
MsgBox ("Please enter a Minor finding value")


ElseIf Textbox1.Value <> "0-25" And Textbox2.Value <> "0-25" Then
Worksheets("International ccu tracker").Range("AI" & xcell.Row).Value = Textbox1.Value
Worksheets("International ccu tracker").Range("AJ" & xcell.Row).Value = Textbox2.Value
MsgBox ("Rating calculated")

Textbox3.Font.Size = 14
Textbox3.TextAlign = 2

End If
Next xcell
Exit Sub
End Sub

This is the Userform trigger code 这是用户窗体触发代码

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim question As Integer

    If Not Intersect(Target, Me.Range("Userformrange")) Is Nothing Then

        question = MsgBox("Would you like to add or edit a rating?", vbYesNo)
        If question = vbYes Then
            UserForm1.Show
        Else 
            Exit Sub
        End If
    End If
End Sub

Untested: 未经测试:

Worksheet: 工作表:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rng As Range
    Set rng = Intersect(Target, Me.Range("Userformrange"))

    If Not rng Is Nothing Then
        If MsgBox("Would you like to add or edit a rating?", vbYesNo) = vbYes Then
            ' "TheCell" is a public global in your userform (or make a property Get/Let)
            Set UserForm1.TheCell = rng.Cells(1) 'only dealing with one row at a time...
            UserForm1.Show
        Else
            Exit Sub
        End If
    End If
End Sub

Userform: 窗体:

Public TheCell As Range 'public variable in your form

Private Sub Calculateseveritybutton_Click()
    If Textbox1.Value = "0-25" Or Textbox2.Value = "0-25" Then
        MsgBox "Minor and Major finding values are both required!", vbExclamation
    Else
        With TheCell.EntireRow
            .Cells(1, "AI").Value = Textbox1.Value 'Cells is *relative* here...
            .Cells(1, "AJ").Value = Textbox2.Value
            MsgBox ("Rating calculated")
            Textbox3.Font.Size = 14
            Textbox3.TextAlign = 2
        End With
    End If
End Sub

声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM