Excel VBA Forms - форматирование чисел и изменение события - PullRequest
Новая
       31

Excel VBA Forms - форматирование чисел и изменение события

0 голосов
/ 30 июня 2019

2 части вопроса: я построил форму для отображения большого ряда информации в более приемлемом формате. Во-первых, событие OnChange, которое я нашел здесь: https://stackoverflow.com/a/5942200/2317071, раньше работало, но оно перестало работать, когда я немного выделил свой код. Во-вторых, действительно ли мне нужно вручную форматировать текстовое поле в соответствии с форматом ячейки каждый раз? У меня проблемы с преобразованием чисел обратно; например 13,5% устанавливаются на 0,135 (достаточно справедливо), но не для ячейки и текстового поля.

Надеюсь, мой код достаточно прокомментирован, чтобы его можно было прочитать, но по сути я создаю форму, которую можно использовать на одном из нескольких листов, чтобы отобразить всю активную строку данных в форме. Каждый лист кандидата имеет значение ИСТИНА или ЛОЖЬ в каждой ячейке в строке 1. Если столбец имеет значение ИСТИНА, это поле включается в форму, в противном случае я перехожу к следующему полю, которое пользователь хочет отобразить. Если ячейка в активной строке является формулой, пользователь не может редактировать текстовое поле. Если пользователь изменяет одно из значений, я хочу определить это и дать возможность сохранить, а затем записать новое значение обратно в активную строку в соответствующей ячейке.

Что мне здесь не хватает? Спасибо за вашу помощь!

С https://stackoverflow.com/a/5942200/2317071: Модуль класса "clsTextBox", содержит: 

Private WithEvents MyTextBox As MSForms.TextBox

Public Property Set Control(tb As MSForms.TextBox)
    Set MyTextBox = tb
End Property

Private Sub MyTextBox_Change()
    FormDataChanged = True
End Sub

Module_FormCalls содержит код, который вызывает каждая кнопка, в основном просто устанавливает BaseSheet, а затем вызывает форму: 


Public BaseSheet As Worksheet
Public FormDataChanged As Boolean

Sub CallForm_4B2()
    Dim ThisSheet As Worksheet
    Set ThisSheet = Worksheets("4B2")
    Debug.Print ThisSheet.Name
    Set BaseSheet = ThisSheet
    Debug.Print BaseSheet.Name
    frmRecordDisplay.Show
    Set ThisSheet = Nothing
End Sub

Sub CallForm_4B1()
    Dim ThisSheet As Worksheet
    Set ThisSheet = Worksheets("4B1")
    Debug.Print ThisSheet.Name
    Set BaseSheet = ThisSheet
    Debug.Print BaseSheet.Name
    frmRecordDisplay.Show
    Set ThisSheet = Nothing
End Sub

frmRecordDisplay имеет рабочий код: 


Option Explicit
Dim ColumnUsed(1 To 80) As Integer
Dim DataChangedString As String

Private Sub CommandButtonNext_Click()

    Dim Message As String
    Dim SaveChoice

    If DataChanged() Then 'Custom function shown below to detect differences between what is in each field now and what was originally put in them
'    If FormDataChanged Then 'Event driven by Class Module clsTextBox
        Message = "Data Changed! Save record? " + vbCr + vbCr
        Message = Message + "Yes = Save and move to Next Record" + vbCr
        Message = Message + "No = Don't Save and move to Next Record" + vbCr
        Message = Message + "Cancel = Stay on this record"
        SaveChoice = MsgBox(Message, vbYesNoCancel)

        If SaveChoice = vbCancel Then

        ElseIf SaveChoice = vbNo Then
            'Select next record
            BaseSheet.Cells(ActiveCell.EntireRow.Row + 1, 1).Activate
        ElseIf SaveChoice = vbYes Then
            'Save changes from form back to sheet, then select next record
            SaveData
            BaseSheet.Cells(ActiveCell.EntireRow.Row + 1, 1).Activate
        End If
    Else
        'Nothing changed, select next record
        BaseSheet.Cells(ActiveCell.EntireRow.Row + 1, 1).Activate
    End If
    'If user hit cancel, stay where you are, otherwise refresh the form with the next record selected
    If Not SaveChoice = vbCancel Then UserForm_Initialize
End Sub

Private Sub CommandButtonPrev_Click()

    Dim Message As String
    Dim SaveChoice

    If DataChanged() Then 'Custom function shown below to detect differences between what is in each field now and what was originally put in them
'    If FormDataChanged Then  'Event driven by Class Module clsTextBox
        Message = "Data Changed! Save record? " + vbCr + vbCr
        Message = Message + DataChangedString + vbCr + vbCr
        Message = Message + "Yes = Save and move to Next Record" + vbCr
        Message = Message + "No = Don't Save and move to Next Record" + vbCr
        Message = Message + "Cancel = Stay on this record"
        SaveChoice = MsgBox(Message, vbYesNoCancel)

        If SaveChoice = vbCancel Then

        ElseIf SaveChoice = vbNo Then
            'Select previous record
            BaseSheet.Cells(ActiveCell.EntireRow.Row - 1, 1).Activate
        ElseIf SaveChoice = vbYes Then
            'Save changes from form back to sheet, then select previous record
            SaveData
            BaseSheet.Cells(ActiveCell.EntireRow.Row - 1, 1).Activate
        End If
    Else
        'Nothing changed, select previous record
        BaseSheet.Cells(ActiveCell.EntireRow.Row - 1, 1).Activate
    End If
    'If user hit cancel, stay where you are, otherwise refresh the form with the previous record selected
    If Not SaveChoice = vbCancel Then UserForm_Initialize
End Sub

Private Sub CommandButtonSave_Click()
    Call SaveData
End Sub

Private Sub UserForm_Click()

End Sub

Dim tbCollection As Collection

Private Sub UserForm_Initialize()


'    Dim DataSet(1 To 2, 1 To 100) As Variant
    Dim LastRow As Integer
    Dim FirstRow As Integer
    Dim ActiveRow As Integer
    Dim Column As Integer
    Dim ctrlCounter As Integer
    Dim TextBoxesUsed As Integer
    Dim ColNr As Integer
    Dim ThisCaption As String
    Dim NumberFormat As String
    Dim Value As Variant


    Dim ctrl As MSForms.Control
    Dim obj As clsTextBox
    Dim tbCollection


    'Find the used data range
    LastRow = BaseSheet.Range("A9999").End(xlUp).EntireRow.Row
    FirstRow = 7
    ActiveRow = ActiveCell.EntireRow.Row

    'Limit the records to the used data range
    If ActiveRow > LastRow Then ActiveRow = LastRow
    If ActiveRow < FirstRow Then ActiveRow = FirstRow

    'Disable the Next / Prev buttons when at limits of used range
    Me.CommandButtonNext.Enabled = Not (ActiveRow >= LastRow)
    Me.CommandButtonPrev.Enabled = Not (ActiveRow <= FirstRow)


    'To make the form more usable across multiple sheets, row 1 of each sheet will contain TRUE or FALSE,
    'if the column has TRUE in row 1, that field is shown.
    'Load the list of columns that are TRUE into an array
    ctrlCounter = 1
    For Column = 1 To 150
        If BaseSheet.Cells(1, Column).Value Then
            ColumnUsed(ctrlCounter) = Column
            ctrlCounter = ctrlCounter + 1
        End If
        If ctrlCounter = 80 Then GoTo PageFull 'Can't fit any more fields on the form
    Next Column
PageFull:


    BaseSheet.Cells(ActiveRow, 1).Activate
'    On Error Resume Next
'    For Column = 1 To 62
'        DataSet(1, Column) = BaseSheet.Cells(4, Column).Value
'        DataSet(2, Column) = BaseSheet.Cells(ActiveRow, Column).Value
'        Debug.Print DataSet(1, Column) + " = " + DataSet(2, Column)
'    Next Column
'    On Error GoTo 0
    Debug.Print "BaseSheet.Name = " + BaseSheet.Name

    Me.Caption = "Stage " + BaseSheet.Name + ", Lot " + Str(BaseSheet.Cells(ActiveRow, 5).Value)

    Set tbCollection = New Collection
    'On Error Resume Next

    TextBoxesUsed = 0

    'Loop through each control on the form and action it as required.
    For Each ctrl In Me.Controls
        'ColNr = Val(ctrl.Tag)
        Debug.Print "Checking ctrl " + ctrl.Name
        ctrl.Visible = False    'Turn all controls off, then only turn on the ones we need
        'Each label and text box has the tag value set to the index it corresponds to, i.e. 1 to 80
        If WorksheetFunction.IsNumber(Val(ctrl.Tag)) Then
            If Val(ctrl.Tag) > 0 Then
                ColNr = ColumnUsed(ctrl.Tag) 'Each control has a tag, which is it's index on the page. Get the column of that index from the used array
                Debug.Print "Index = " + Str(ctrl.Tag) + ", ColNr = " + Str(ColNr)

                If ColNr > 0 Then
                    'Index has a valid column, show the label or text box
                    Debug.Print ctrl.Name + " TypeName = " + TypeName(ctrl)
                    ctrl.Visible = True

                    If TypeOf ctrl Is MSForms.Label Then
                        'Get the label for the column from the header row, row 4
                        ThisCaption = Replace(BaseSheet.Cells(4, ColNr).Value, vbCr, "")
                        ctrl.Caption = ThisCaption
                    End If

                    If TypeOf ctrl Is MSForms.TextBox Then
                        'Get the number format from the linked cell so we can format the text box to suit
                        NumberFormat = BaseSheet.Cells(ActiveRow, ColNr).NumberFormat
                        If NumberFormat = "General" Then
                            Value = BaseSheet.Cells(ActiveRow, ColNr).Value
                        Else
                            Value = Format(BaseSheet.Cells(ActiveRow, ColNr).Value, BaseSheet.Cells(ActiveRow, ColNr).NumberFormat)
                        End If

                        'If the cell is a formula, lock it so that it can't be edited.
                        If WorksheetFunction.IsFormula(BaseSheet.Cells(ActiveRow, ColNr)) Then
                            ctrl.Locked = True
                            ctrl.BackColor = &H8000000F
                        Else
                            ctrl.Locked = False
                            ctrl.BackColor = &H8000000B
                        End If

                        ctrl.Value = Value

                        Set obj = New clsTextBox
                        Set obj.Control = ctrl
                        tbCollection.Add obj

                        TextBoxesUsed = TextBoxesUsed + 1
                    End If
                End If 'If ColNr > 0 then
            Else
                If TypeOf ctrl Is MSForms.CommandButton Then
                    'Buttons won't have a tag value set, but we still want to see them.
                    ctrl.Visible = True
                End If
            End If 'If ctrl.Tag > 0 Then

        End If 'If IsInteger(ctrl.Tag) Then
    Next 'ctrl In Me.Controls

    On Error GoTo 0

    'Form has 4 columns of 20 label/text box pairs. Resize the form to only show the columns we need.
    Select Case TextBoxesUsed
        Case 0 To 20: Me.Width = 240
        Case 21 To 40: Me.Width = 460
        Case 41 To 60: Me.Width = 680
        Case 61 To 80: Me.Width = 900
    End Select

    Set obj = Nothing

    FormDataChanged = False
End Sub

Function DataChanged() As Boolean

    Dim ColNr As Integer
    Dim SheetValueStr As String
    Dim ctrlValueStr As String
    Dim RowNr As Integer
    Dim ActiveRow As Integer
    Dim ctrl As Control
    Dim DataChangedTemp As Boolean
    Dim ctrlValue As Variant
    Dim SheetValue As Variant


    RowNr = ActiveCell.EntireRow.Row

    DataChangedTemp = False
    DataChangedString = ""
    ActiveRow = ActiveCell.EntireRow.Row

    'Check each text box against the cell it was originally populated from, to see if it has changed.
    For Each ctrl In Me.Controls
        If TypeOf ctrl Is MSForms.TextBox Then
            'ColNr = Val(ctrl.Tag)
            ColNr = ColumnUsed(ctrl.Tag)
            Debug.Print "ctrlIndex = " + Str(ctrl.Tag) + ", ColNr = " + Str(ColNr)

            'Text boxes linked to cells containing formulas are locked so they can't be edited, these can be ignored for comparison
            If ColNr > 0 And Not ctrl.Locked Then
                Debug.Print ctrl.Name + " TypeName = " + TypeName(ctrl)

                SheetValue = FormattedValue(ColNr, BaseSheet.Cells(ActiveRow, ColNr).Value)
                ctrlValue = FormattedValue(ColNr, ctrl.Value)


                If Application.WorksheetFunction.IsNumber(SheetValue) Then
                    SheetValueStr = Str(SheetValue)
                Else
                    SheetValueStr = SheetValue
                End If

                If ctrlValue = Val(ctrlValue) Then
                'If Application.WorksheetFunction.IsNumber(ctrlValue) Then
                    ctrlValueStr = Str(ctrlValue)
                    ctrlValue = Val(ctrlValue)
                Else
                    ctrlValueStr = ctrlValue
                End If
                Debug.Print "Heading = " + BaseSheet.Cells(4, ColNr).Value
                Debug.Print "SheetValue = " + SheetValueStr + ", ctrlValue = " + ctrlValueStr

                If ctrlValue <> SheetValue Then
                    DataChangedTemp = True
                    DataChangedString = DataChangedString + BaseSheet.Cells(4, ColNr).Value + ": "  'Header row
                    DataChangedString = DataChangedString + "SheetValueStr = " + SheetValueStr      'Value from the sheet
                    DataChangedString = DataChangedString + ", ctrlValueStr = " + ctrlValueStr      'Value from the form
                End If

            End If 'If ColNr > 0 then
        End If 'If TypeOf ctrl Is MSForms.TextBox Then
    Next 'ctrl In Me.Controls

    DataChanged = DataChangedTemp
End Function

Sub SaveData()

    Dim ctrl As Control
    Dim ColNr As Integer
    Dim ActiveRow As Integer

    ActiveRow = ActiveCell.EntireRow.Row

    For Each ctrl In Me.Controls
        'ColNr = Val(ctrl.Tag)
        ColNr = ColumnUsed(ctrl.Tag)

        If ColNr > 0 Then
            On Error Resume Next
            Debug.Print
            Debug.Print ctrl.Name + " is " + TypeName(ctrl)
            Debug.Print "Heading = " + BaseSheet.Cells(4, ColNr).Value
            Debug.Print "Value = " + ctrl.Value

            If TypeOf ctrl Is MSForms.TextBox Then
               ' ThisCellType = CellType(BaseSheet.Cells(ActiveRow, ColNr))
'                ThisCellType = BaseSheet.Cells(ActiveRow, ColNr).NumberFormat
'                Debug.Print "BaseSheet.Cells(" + Str(ActiveRow) + "," + Str(ColNr) + ").Type = " + ThisCellType
'                Select Case ThisCellType
'                    Case "General"
'                        BaseSheet.Cells(ActiveRow, ColNr).Value = ctrl.Value
'                    Case "dd/mm/yyyy"
'                        BaseSheet.Cells(ActiveRow, ColNr).Value = DateValue(ctrl.Value)
'                    Case "m/d/yyyy"
'                        If ctrl.Value = "" Then
'                            BaseSheet.Cells(ActiveRow, ColNr).Value = ""
'                        Else
'                            BaseSheet.Cells(ActiveRow, ColNr).Value = DateValue(ctrl.Value)
'                        End If
'                    Case "Text"
'                        BaseSheet.Cells(ActiveRow, ColNr).Value = ctrl.Value
'                    Case "Number"
'                         BaseSheet.Cells(ActiveRow, ColNr).Value = Val(ctrl.Value)
'                    Case "#,##0.00"
'                         BaseSheet.Cells(ActiveRow, ColNr).Value = Val(ctrl.Value)
'                    Case Else
'                         Stop
'                End Select
                BaseSheet.Cells(ActiveRow, ColNr).Activate
                'Don't write a value back to the cell if it contains a formula
                If Not WorksheetFunction.IsFormula(BaseSheet.Cells(ActiveRow, ColNr)) Then BaseSheet.Cells(ActiveRow, ColNr).Value = FormattedValue(ColNr, ctrl.Value)
            End If
            On Error GoTo 0
        End If 'If ColNr > 0 then
    Next 'ctrl In Me.Controls
End Sub


Function CellType(c)
'   Returns the cell type of the upper left
'   cell in a range
    Application.Volatile
    Set c = c.Range("A1")
    cNumberFormat = c.NumberFormat
    Select Case True
        'Case IsEmpty(c): CellType = "Blank"
        Case Application.IsText(c): CellType = "Text"
        Case Application.IsLogical(c): CellType = "Logical"
        Case Application.IsErr(c): CellType = "Error"
        Case IsDate(c): CellType = "Date"
        Case InStr(1, c.Text, ":") <> 0: CellType = "Time"
        Case IsNumeric(c): CellType = "Value"
        Case Else: Stop
    End Select
End Function

Function FormattedValue(ColNr As Integer, ctrlValue As Variant) As Variant

    Dim ActiveRow As Integer
    Dim ThisCellType As String

    ActiveRow = ActiveCell.EntireRow.Row
    ' ThisCellType = CellType(BaseSheet.Cells(ActiveRow, ColNr))
    ThisCellType = BaseSheet.Cells(ActiveRow, ColNr).NumberFormat
    Debug.Print "BaseSheet.Cells(" + Str(ActiveRow) + "," + Str(ColNr) + ").Type = " + ThisCellType
    Select Case ThisCellType
         Case "General", "Text"
             FormattedValue = ctrlValue
         Case "0.0%", "0.00%"
             FormattedValue = Val(Replace(ctrlValue, "%", ""))
         Case "dd/mm/yyyy", "d/mm/yyyy;@", "m/d/yyyy", "d/mm/yy;@", "dd/mm/yy;@", "dd/mm/yyyy;@", "dd-mmm-yyyy"
             If ctrlValue = "" Then
                 FormattedValue = ""
             Else
                 FormattedValue = DateValue(ctrlValue)
             End If
         Case "Number", "0", "#,##0", "#,##0.00", "#,##0_ ;-#,##0", "#,##0_ ;-#,##0 ", """$""#,##0.00", """$""#,##0.00;[Red]-""$""#,##0.00"
             FormattedValue = Val(Replace(Replace(ctrlValue, "$", ""), ",", ""))
         Case Else
             Stop
    End Select
    On Error Resume Next
    Debug.Print "BaseSheet.Cells(" + Str(ActiveRow) + "," + Str(ColNr) + ").Value = " + Format(BaseSheet.Cells(ActiveRow, ColNr).Value, ThisCellType)
    Debug.Print "FormattedValue = " + Str(FormattedValue)
    On Error GoTo 0
End Function
...