Data Form Ver 2.0

Thảo luận trong 'Ứng dụng Excel' bắt đầu bởi levanduyet, 4 Tháng một 2005.

4,093 lượt xem

  1. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    Data form I
    Bạn thường xuyên phải nhập liệu, có thể data form ver 2.0 có thể giúp cho bạn. Đây là phiên bản miễn phí, các bạn có thể download từ đây:
    http://j-walk.com/ss/dataform/download.htm
    Đây là đoạn code của module

    Option Explicit

    ' NOTE: Non-English translation is done in Sheet1 of this workbook.
    ' Set the IsAddIn property to False, and enter the translations.
    ' Then set the IsAddIn property to True
    ' Set the LANGUAGE constant to correspond to the column

    Public Const LANGUAGE As Long = 1
    Public Const APPNAME As String = "JWalk Enhanced Data Form" 'displayed in title bars

    'CriteriaData is a custom data type for the Criteria array
    Type CriteriaData
    FieldNumber As Long
    Value As Variant
    End Type

    'UndoData is a custom data type used for undoing a Delete or a data entry
    Type UndoData
    RecNum As Long
    Address As String
    Contents As Variant
    End Type

    Public UndoArray() As UndoData
    Public Criteria() As CriteriaData 'Stores the criteria when searching
    Public DatabaseRange As Range 'The range that contains the worksheet database
    Public Text(1 To 36) As String 'Stores the text items used in the Form

    Sub ShowDataForm()
    ' This is the "entry" subroutine that is executed
    ' To execute this procedure from a VBA procedure in a different project, use:
    ' Application.Run "dataform.xla!ShowDataForm"

    ' Note: The ThisWorkbook code module contains code to create the new menu item on the Data menu

    ' Sheet protected?
    If ActiveSheet.ProtectContents Then
    MsgBox "This command cannot be used on a protected worksheet." & vbCrLf & "Use the Tools - Protection - Unprotect Sheet command and try again.", vbCritical, APPNAME
    Exit Sub
    End If

    ' Create a Range variable for the database
    Set DatabaseRange = ActiveCell.CurrentRegion

    ' Check for single cell
    If DatabaseRange.Count = 1 Then
    MsgBox "Cannot detect a database at the active cell." & vbCrLf & vbCrLf & "Select any cell within the database and try again.", vbCritical, APPNAME
    Exit Sub
    End If

    ' Check for empty database
    If DatabaseRange.Rows.Count = 1 And DatabaseRange.Columns.Count > 2 Then
    If MsgBox("Cannot detect a database at the active cell." & vbCrLf & vbCrLf & "Do you want to use the current row as field names for a new database?", vbCritical + vbYesNo, APPNAME) = vbNo Then Exit Sub
    DatabaseRange(2, 1).Select
    ActiveCell.Value = "[New]"
    Set DatabaseRange = ActiveCell.CurrentRegion
    End If

    ' Display the main dialog box
    ' This causes the FormMain_Initialize subroutine to execute
    ' The remainder of the code is in the FormMain code module
    FormMain.Show
    End Sub

    Đây là đoạn code của form main
    Option Explicit

    Public RowOffset As Long ' No. of rows database is offset from the top
    Public ColumnOffset As Long ' No. of columns database is offset from the left
    Public RecordCount As Long, FieldCount As Long
    Public CurrentRecord As Long 'Stores the current record, displayed in the form
    Public ScrollBarClicked As Boolean 'Flag that determines how ScrollBar1_Change was called
    Public InsertedRow As Long 'Used to undo a row insert
    Public InsertedRec As Long 'Used to undo a row insert
    Public CriteriaEntered As Boolean 'True if criteria are entered in the Criteria page
    Public CriteriaCount As Long 'number of criteria entered

    Private Sub UserForm_Initialize()
    'This sub is executed before FormMain is displayed
    Dim i As Long, j As Long, k As Long
    Dim CurrentFrame As Frame
    Dim VerticalPosition As Long
    Dim NewLabel As Control
    Dim NewControl As Control
    Dim Options As Range
    Dim ctl As Control
    Dim ModifiedName As String
    Dim ComboBoxOptions As Variant

    'Get the text items
    Call TranslateText(LANGUAGE)

    Me.Width = UserWidth() 'Function looks for DF_WIDTH name
    Me.Height = UserHeight() 'Function looks for DF_HEIGHT name

    'If DF_WIDTH and/or DF_HEIGHT range names exist, change the form dimensions
    If Me.Width <> 270 Or Me.Height <> 240 Then '270 and 240 are the default dimensions
    MultiPage1.Width = Me.Width - 20
    MultiPage1.Height = Me.Height - 54
    HelpButton.Top = Me.Height - 42
    LabelRecNum.Top = Me.Height - 38
    UndoButton.Top = Me.Height - 42
    CloseButton.Top = Me.Height - 42
    ScrollBar1.Top = MultiPage1.Height - 36
    NewButton.Left = MultiPage1.Width - 60
    InsertButton.Left = MultiPage1.Width - 60
    DeleteButton.Left = MultiPage1.Width - 60
    FindPreviousButton.Left = MultiPage1.Width - 60
    FindNextButton.Left = MultiPage1.Width - 60
    ClearCriteriaButton.Left = MultiPage1.Width - 60
    TipsButton.Left = MultiPage1.Width - 60
    CloseButton.Left = Me.Width - 60
    UndoButton.Left = CloseButton.Left - 66
    Frame1.Width = MultiPage1.Width - 74
    Frame1.Height = MultiPage1.Height - 48
    Frame2.Width = MultiPage1.Width - 74
    Frame2.Height = MultiPage1.Height - 48
    ScrollBar1.Width = Frame1.Width
    End If

    'Set the caption for the form
    Me.Caption = APPNAME

    'Determine the offsets (important if the database does not begin in A1)
    RowOffset = DatabaseRange.Rows(1).Row
    ColumnOffset = DatabaseRange.Columns(1).Column - 1

    'Determine the size of the database
    RecordCount = DatabaseRange.Rows.Count - 1 'First row is assumed to be labels
    FieldCount = DatabaseRange.Columns.Count

    'Set up the Labels and TextBoxes/ComboBoxes for the fields dynamically
    For i = 1 To 2
    'First time thru, do Page1 (Data entry, Frame1 on Page1 of the MultiPage control)
    'Second time thru do Page2 (Criteria, Frame2 on Page2 of the MultiPage control)
    If i = 1 Then Set CurrentFrame = Frame1 Else Set CurrentFrame = Frame2
    VerticalPosition = 5 'controls the vertical placement of the controls
    For j = 1 To FieldCount
    'Add a label
    Set NewLabel = CurrentFrame.Controls.Add("forms.label.1")
    With NewLabel
    .Top = VerticalPosition + 3
    .Left = 4
    .Width = 60
    .TextAlign = 3
    .WordWrap = False
    .Caption = Application.WorksheetFunction.Clean(DatabaseRange.Cells(1, j))
    .Height = 16
    .Font.Size = 8
    End With
    'Is a Name defined with an array of choices?
    ModifiedName = Application.Substitute(NewLabel.Caption, " ", "_")

    If NameHasData(ModifiedName) Then
    'Add a ComboBox
    Set NewControl = CurrentFrame.Controls.Add("forms.combobox.1")
    ComboBoxOptions = UNIQUEITEMS(Worksheets(Range(ModifiedName).Parent.Name).Range(ModifiedName))
    If IsArray(ComboBoxOptions) Then NewControl.List = ComboBoxOptions
    Else
    'Add a TextBox
    Set NewControl = CurrentFrame.Controls.Add("forms.textbox.1")
    End If
    With NewControl
    .Top = VerticalPosition
    .Left = 66
    'Adjust the width, based on whether scroll bar appears in the frame
    If FieldCount * 18 > Frame1.Height Then
    .Width = Me.Frame1.Width - 85 'scroll bar present
    Else
    .Width = Me.Frame1.Width - 72
    End If
    .Height = 16
    .Font.Size = 8
    End With
    VerticalPosition = VerticalPosition + 18 'increment
    Next j

    'Determine how much to scroll the frame, based on the number of fields
    CurrentFrame.ScrollHeight = (FieldCount * 18) + 5
    Next i

    'Display the record in the row of the active cell
    CurrentRecord = ActiveCell.Row - DatabaseRange.Rows(1).Row
    If CurrentRecord = 0 Then CurrentRecord = 1 'Title row is selected

    'Make sure Page1 of the MultiPage control is displayed
    MultiPage1.Value = 0
    MultiPage1_Change ' Call the sub that's executed when the page is changed

    'Set up the record scroll bar
    'ScrollBar1 is always in sync with the CurrentRecord
    With ScrollBar1
    .Min = 1
    .Max = RecordCount
    .Value = CurrentRecord
    End With

    'Update the form
    Call UpdateForm

    'Set the focus to the first field
    On Error Resume Next
    With Frame1.Controls(1)
    .SelStart = 0
    .SelLength = Len(Frame1.Controls(1).Text)
    .SetFocus
    End With

    ScrollBarClicked = True
    Range(Cells(CurrentRecord + RowOffset, 1 + ColumnOffset), Cells(CurrentRecord + RowOffset, ColumnOffset + FieldCount)).Select
    End Sub
     
    #1
  2. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    Data Form II
    Private Sub UndoButton_Click()
    'Executed when the UndoButton is clicked
    'The UndoButton is visible only when something
    'can be udone (Insert a record, Delete a record, or New record)
    'The UndoButton caption describes what will be undone

    Dim i As Long
    Dim OldRec As Long
    Dim CurrentRow As Long

    OldRec = CurrentRecord
    Select Case UndoButton.Caption
    Case Text(15) '"Undo Delete"
    'UndoArray array is created when a record is deleted
    CurrentRecord = UndoArray(1).RecNum
    Range(Cells(CurrentRecord + RowOffset, ColumnOffset + 1), Cells(CurrentRecord + RowOffset, ColumnOffset + FieldCount)).Insert Shift:=xlDown
    For i = 1 To FieldCount
    Range(UndoArray(i).Address).Formula = UndoArray(i).Contents
    Next i
    RecordCount = RecordCount + 1

    UndoButton.Visible = False
    ScrollBarClicked = False
    ScrollBar1.Max = RecordCount
    ScrollBar1.Value = CurrentRecord
    Range(Cells(CurrentRecord + RowOffset, 1 + ColumnOffset), Cells(CurrentRecord + RowOffset, ColumnOffset + FieldCount)).Select
    UpdateForm
    'If 1st row is being restored, copy formats from 2nd row
    If UndoArray(1).RecNum = 1 Then CopyFormatsAndFormulas (1)

    Case Text(16) ' "Undo Insert"
    'The InsertedRow variable is set when a record is inserted
    CurrentRow = ActiveCell.Row
    Range(Cells(InsertedRow, ColumnOffset + 1), Cells(InsertedRow, ColumnOffset + FieldCount)).Delete Shift:=xlUp
    RecordCount = RecordCount - 1
    UndoButton.Visible = False
    ScrollBarClicked = False
    ScrollBar1.Max = RecordCount

    'Delete inserted record
    CurrentRecord = InsertedRec
    Range(Cells(InsertedRow, ColumnOffset + 1), Cells(InsertedRow, ColumnOffset + FieldCount)).Select
    ScrollBar1.Value = CurrentRecord
    UpdateForm

    Case Text(17) ' "Undo New"
    'The InsertedRow variable is set when a record a new record is added
    Range(Cells(InsertedRow, ColumnOffset + 1), Cells(InsertedRow, ColumnOffset + FieldCount)).Delete
    RecordCount = RecordCount - 1
    UndoButton.Visible = False
    ScrollBarClicked = False
    ScrollBar1.Max = RecordCount
    CurrentRecord = OldRec
    If CurrentRecord > RecordCount Then ' active record is the new record
    CurrentRecord = RecordCount
    Range(Cells(CurrentRecord + RowOffset, 1 + ColumnOffset), Cells(CurrentRecord + RowOffset, ColumnOffset + FieldCount)).Select
    End If
    ScrollBar1.Value = CurrentRecord
    UpdateForm

    Case Text(18) ' "Undo Entry"
    'Restores last data written to database
    CurrentRecord = UndoArray(1).RecNum
    ScrollBarClicked = False
    ScrollBar1.Value = CurrentRecord
    For i = 1 To UBound(UndoArray)
    Range(UndoArray(i).Address).Formula = UndoArray(i).Contents
    Next i
    Range(Cells(CurrentRecord + RowOffset, 1 + ColumnOffset), Cells(CurrentRecord + RowOffset, ColumnOffset + FieldCount)).Select
    UpdateForm
    UndoButton.Visible = False
    End Select
    ScrollBarClicked = True
    If Err <> 0 Then
    'A catch-all error message
    MsgBox Text(21), vbInformation, APPNAME
    End If
    End Sub
    Private Sub MultiPage1_Change()
    'This sub is executed when the user clicks a tab on the MultiPage control

    Dim ctl As Control
    Dim FieldNum As Long

    'Save the user's search criteria in the Criteria array (which uses a custom data type)
    CriteriaCount = 0
    FieldNum = 0
    For Each ctl In Frame2.Controls
    If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then
    FieldNum = FieldNum + 1
    If ctl.Text <> "" Then
    CriteriaCount = CriteriaCount + 1
    ReDim Preserve Criteria(1 To CriteriaCount)
    Criteria(CriteriaCount).FieldNumber = FieldNum
    Criteria(CriteriaCount).Value = ctl.Text
    End If
    End If
    Next ctl

    'Are there any criteria entered in Frame2?
    If CriteriaCount = 0 Then CriteriaEntered = False Else CriteriaEntered = True

    'Change the captions for the Find and Next buttons, if necessary
    If CriteriaEntered Then
    FindPreviousButton.Caption = Text(19)
    FindNextButton.Caption = Text(20)
    MultiPage1.page2.Caption = "<<" & Text(3) & ">>"
    Else
    FindPreviousButton.Caption = Text(7)
    FindNextButton.Caption = Text(8)
    MultiPage1.page2.Caption = Text(3)
    End If

    'Set the focus to the first field
    On Error Resume Next
    If MultiPage1.Value = 0 Then
    With Frame1.Controls(1)
    .SelStart = 0
    .SelLength = Len(Frame1.Controls(1).Text)
    .SetFocus
    End With
    Else
    With Frame2.Controls(1)
    .SelStart = 0
    .SelLength = Len(Frame1.Controls(1).Text)
    .SetFocus
    End With
    End If
    End Sub

    Private Sub FindNextButton_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    'This sub is included to avoid the delay if the user clicks the button quickly
    Call FindNextButton_Click
    End Sub

    Private Sub FindNextButton_Click()
    'Executed when the "Find Next" or "Next" button is clicked

    If FindNextButton.Caption = Text(20) Then '"Find Next"
    'Criteria are in effect
    Call FindARecord("Down")
    Else
    'Criteria are not in effect
    If ScrollBar1.Value <> ScrollBar1.Max Then
    ScrollBar1.Value = ScrollBar1.Value + 1
    Else
    Beep
    End If
    On Error Resume Next
    End If
    End Sub
    Private Sub FindPreviousButton_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    'This sub is included to avoid the delay if the user clicks the button quickly
    Call FindPreviousButton_Click
    End Sub

    Private Sub FindPreviousButton_Click()
    'Executed when the "Find Prev" or "Previous" button is clicked

    If FindPreviousButton.Caption = Text(19) Then '"Find Prev"
    'Criteria are in effect
    Call FindARecord("Up")
    Else
    'Criteria are not in effect
    If ScrollBar1.Value <> 1 Then
    ScrollBar1.Value = ScrollBar1.Value - 1
    Else
    Beep
    End If
    End If
    End Sub

    Private Sub FindARecord(Direction)
    'Executed by the FindNextButton_Click() and FindPreviousButton_Click() subs
    'The Direction argument determines how to search (up or down)
    'Using an argument eliminates the need to have two subroutines

    Dim Roffset As Long 'Row offset for searching
    Dim StopPoint As Long ' Where to stop searching
    Dim CriteriaCount As Long 'Number of criteria entered
    Dim FieldNum As Long
    Dim ctl As Control
    Dim OldSelection As Range
    Dim OldRecord As Long
    Dim AllMatch As Boolean
    Dim i As Long, Row As Long
    Dim RecordFound As Boolean

    If Direction = "Down" Then
    Roffset = 1
    StopPoint = RecordCount + RowOffset + 1
    Else
    Roffset = -1
    StopPoint = RowOffset
    End If

    '(Criteria are stored in Criteria array in MultiPage1_Change)

    'Save the current position
    Set OldSelection = Selection
    OldRecord = CurrentRecord
    Application.ScreenUpdating = False

    UpdateDatabase

    On Error Resume Next
    For Row = ActiveCell.Row + Roffset To StopPoint Step Roffset
    Cells(Row, ColumnOffset + 1).Activate

    'Search for a matching record
    RecordFound = False
    'AllMatch is True if all criteria match in a record
    AllMatch = True
    For i = 1 To UBound(Criteria)
    If Left(Criteria(i).Value, 1) = ">" Or _
    Left(Criteria(i).Value, 1) = "<" Or _
    Left(Criteria(i).Value, 2) = "<>" Or _
    Left(Criteria(i).Value, 2) = ">=" Or _
    Left(Criteria(i).Value, 2) = "<=" Or _
    Left(Criteria(i).Value, 2) = "<>" Then
    'Handle "greater than" or "less than" cases
    Dim x, Y
    x = """" & ActiveCell.Offset(0, Criteria(i).FieldNumber - 1).Value & """"
    Y = Criteria(i).Value
    If Not Evaluate(ActiveCell.Offset(0, Criteria(i).FieldNumber - 1).Value & Criteria(i).Value) Then
    AllMatch = False 'It didn't match
    Exit For
    End If
    Else
    'Use the Like operator for approximate matches
    If Not UCase(ActiveCell.Offset(0, Criteria(i).FieldNumber - 1).Value) Like UCase(Criteria(i).Value) Then
    AllMatch = False 'It didn't match
    Exit For
    End If
    End If
    Next i

    'Did all of the criteria match?
    If AllMatch Then
    CurrentRecord = ActiveCell.Row - RowOffset
    UpdateForm
    Application.ScreenUpdating = True
    ScrollBar1.Value = CurrentRecord
    Exit Sub
    End If
    Next Row 'Didn't match, so try the next (or previous) row

    'Reached the end (or beginning) and no matching records were found
    MsgBox Text(22), vbInformation, APPNAME
    CurrentRecord = OldRecord
    OldSelection.Select
    Application.ScreenUpdating = True
    Exit Sub
    End Sub
     
    #2
  3. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    Data Form III
    Private Sub DeleteButton_Click()
    'Deletes the current record
    Dim i As Long
    ReDim UndoArray(1 To FieldCount)

    'Check for last record
    If RecordCount = 1 Then
    MsgBox Text(23), vbInformation, APPNAME '"You can't delete the only record."
    UndoButton.Visible = False
    Exit Sub
    End If

    'Save this info for undoing
    For i = 1 To FieldCount
    UndoArray(i).RecNum = CurrentRecord
    UndoArray(i).Address = Cells(CurrentRecord + RowOffset, i + ColumnOffset).Address
    UndoArray(i).Contents = Cells(CurrentRecord + RowOffset, i + ColumnOffset).PrefixCharacter & Cells(CurrentRecord + RowOffset, i + ColumnOffset).Formula
    Next i

    'Display the Undo button
    UndoButton.Visible = True
    UndoButton.Caption = Text(15) '"Undo Delete"

    'Delete it, shifting cells up
    Range(Cells(CurrentRecord + RowOffset, ColumnOffset + 1), Cells(CurrentRecord + RowOffset, ColumnOffset + FieldCount)).Delete Shift:=xlUp

    'Was it the last record?
    If CurrentRecord = RecordCount Then CurrentRecord = CurrentRecord - 1
    Range(Cells(CurrentRecord + RowOffset, 1 + ColumnOffset), Cells(CurrentRecord + RowOffset, ColumnOffset + FieldCount)).Select

    'Decrement the record count
    RecordCount = RecordCount - 1

    ' Adjust ScrollBar1
    ScrollBarClicked = False
    ScrollBar1.Max = RecordCount
    ScrollBar1.Value = CurrentRecord
    ScrollBarClicked = True
    UpdateForm
    End Sub

    Private Sub InsertButton_Click()
    'Inserts a new record at the current position

    Dim Col As Long
    Dim ctl As Control

    UpdateDatabase
    For Each ctl In Frame1.Controls
    If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then ctl = ""
    Next ctl

    'Error will occur if last row is not empty
    On Error Resume Next

    'Insert, shifting cells down
    Range(Cells(CurrentRecord + RowOffset, ColumnOffset + 1), Cells(CurrentRecord + RowOffset, ColumnOffset + FieldCount)).Insert Shift:=xlDown

    If Err <> 0 Then
    '"Cannot insert a new record. Likely cause: The last row of the worksheet is not empty."
    MsgBox Text(24), vbCritical, APPNAME
    Exit Sub
    End If

    'Save this info for undoing
    InsertedRow = ActiveCell.Row
    InsertedRec = CurrentRecord

    UndoButton.Visible = True
    UndoButton.Caption = Text(16) '"Undo Insert"
    RecordCount = RecordCount + 1
    ScrollBar1.Max = RecordCount
    Call CopyFormatsAndFormulas(1)
    UpdateForm
    With Frame1.Controls(1)
    .SelStart = 0
    .SelLength = Len(Frame1.Controls(1).Text)
    .SetFocus
    End With
    End Sub

    Private Sub NewButton_Click()
    'Adds a new record to the end of the database

    Dim FormulaCopied As Boolean
    Dim RecordIsEmpty As Boolean
    Dim Col As Long
    Dim ctl As Control

    'Ensure that data won't be overwritten
    On Error Resume Next
    RecordIsEmpty = True
    For Col = 1 To FieldCount ' see if the range is empty
    If Not IsEmpty(DatabaseRange.Cells(RecordCount + 2, Col)) Then RecordIsEmpty = False
    Next Col

    If Not RecordIsEmpty Or Err <> 0 Then 'not empty, warn user
    '"Cannot add a new record to the database because the next row is not empty."
    MsgBox Text(25), vbCritical, APPNAME
    Exit Sub
    End If

    UpdateDatabase
    For Each ctl In Frame1.Controls
    If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then ctl = ""
    Next ctl

    RecordCount = RecordCount + 1
    CurrentRecord = RecordCount
    ScrollBar1.Max = RecordCount
    ScrollBar1.Value = CurrentRecord

    ' Save this info for undoing
    InsertedRow = ActiveCell.Row
    InsertedRec = CurrentRecord
    UndoButton.Visible = True
    UndoButton.Caption = Text(17) '"Undo New"

    Call CopyFormatsAndFormulas(-1)
    UpdateForm
    With Frame1.Controls(1)
    .SelStart = 0
    .SelLength = Len(Frame1.Controls(1).Text)
    .SetFocus
    End With

    End Sub

    Sub CopyFormatsAndFormulas(Direction)
    'Copies formatting and formulas from a row to the current record
    'Called by InsertButton and NewButton
    'if Direction = -1, copy from previous row
    'if Direction = 1, copy from next row

    Dim Col As Long
    Dim FormulaCopied As Boolean

    'Copy formats
    Range(ActiveCell.Offset(Direction, 0), ActiveCell.Offset(Direction, FieldCount - 1)).Copy
    ActiveCell.Select
    Selection.PasteSpecial Paste:=xlPasteFormats

    'Copy formulas
    FormulaCopied = False
    For Col = 0 To FieldCount - 1
    If ActiveCell.Offset(Direction, Col).HasFormula Then
    ActiveCell.Offset(0, Col).FormulaR1C1 = ActiveCell.Offset(Direction, Col).FormulaR1C1
    FormulaCopied = True
    End If
    Next Col
    Application.CutCopyMode = False 'eliminates the "marquee"

    'If no formulas were copied, put a dummy value in the record
    '(a blank row will split up the database)
    If Not FormulaCopied Then ActiveCell = "[New]"
    End Sub
     
    #3
  4. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    Data Form IV
    Private Sub CloseButton_Click()
    'Unloads the form
    'UpdateDatabase
    Unload Me
    End Sub

    Private Sub ScrollBar1_Change()
    'Executed whenever the horizontal scroll bar changes
    Dim OldScroll As Long

    'If the scroll bar was called by another sub, exit now
    'ScrollBarClicked is a Public variable that's set by other subs (such as DeleteButton_Click)
    If Not ScrollBarClicked Then Exit Sub

    UpdateDatabase
    CurrentRecord = ScrollBar1.Value

    'Select the current record
    'This causes the worksheet to scroll so the currentrecord is always visible
    Range(Cells(CurrentRecord + RowOffset, 1 + ColumnOffset), Cells(CurrentRecord + RowOffset, ColumnOffset + FieldCount)).Select

    UpdateForm

    'Set the focus to the first field
    'For an unknown reason, the focus must first be set to the ScrollBar1
    ScrollBar1.SetFocus
    On Error Resume Next
    OldScroll = Frame1.ScrollTop ' Don't change user's scroll setting
    With Frame1.Controls(1)
    .SelStart = 0
    .SelLength = Len(.Text)
    .SetFocus
    End With
    Frame1.ScrollTop = OldScroll
    End Sub


    Sub UpdateForm()
    'This sub updates the fields in the form
    Dim ctl As Control
    Dim Col As Long
    Dim CurrentCell As Range
    Col = 0

    On Error Resume Next
    For Each ctl In Frame1.Controls
    If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then
    Col = Col + 1
    Set CurrentCell = Cells(CurrentRecord + RowOffset, Col + ColumnOffset)
    ctl = CurrentCell
    If CurrentCell.PrefixCharacter = "'" Then ctl = "'" & ctl

    'Check for True/False cells (they would appear as 0 or -1)
    If Application.WorksheetFunction.IsLogical(CurrentCell) Then
    ctl = CurrentCell.Text
    End If

    'Is the cell displaying an error value?
    If Err <> 0 Then
    ctl = CurrentCell.Text 'Display this if the cell has an error value
    Err = 0
    End If

    'Formula?
    If Cells(CurrentRecord + RowOffset, Col + ColumnOffset).HasFormula Then
    ctl.Enabled = False
    ctl.BackColor = RGB(240, 240, 240)
    Else
    ctl.Enabled = True
    ctl.BackColor = RGB(255, 255, 255)
    End If
    End If
    Next ctl
    LabelRecNum = Text(9) & " " & CurrentRecord & " " & Text(10) & " " & RecordCount
    On Error GoTo 0
    End Sub

    Sub UpdateDatabase()
    'Updates the database with new data from the form
    Dim ctl As Control
    Dim Col As Long
    Dim TestCell As Range
    Dim NumberWritten As Long
    Col = 0
    NumberWritten = 0
    For Each ctl In Frame1.Controls
    If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then
    Col = Col + 1
    Set TestCell = Cells(CurrentRecord + RowOffset, Col + ColumnOffset)
    If Not TestCell.HasFormula Then ' Don't check formula cells
    'Use Clean so cells with non-printing characters will be compared correctly
    If TestCell.PrefixCharacter & Application.WorksheetFunction.Clean(TestCell) <> Application.WorksheetFunction.Clean(ctl.Text) Then
    'Save original data for undo
    NumberWritten = NumberWritten + 1
    ReDim Preserve UndoArray(1 To NumberWritten)
    With UndoArray(NumberWritten)
    .Address = TestCell.Address
    .Contents = TestCell.PrefixCharacter & TestCell.Text
    .RecNum = CurrentRecord
    End With
    'write the new data
    TestCell = ctl.Text
    End If
    End If
    End If
    Next ctl

    If NumberWritten <> 0 Then
    UndoButton.Caption = Text(18) '"Undo Entry"
    UndoButton.Visible = True
    End If
    End Sub

    Private Sub TipsButton_Click()
    ' Displays a msgbox from the Criteria page
    Dim Msg As String
    Msg = Text(26)
    Msg = Msg & " " & Text(27) & vbCrLf & vbCrLf
    Msg = Msg & Text(28) & vbCrLf & vbCrLf
    Msg = Msg & " *" & vbTab & Text(29) & vbCrLf
    Msg = Msg & " ?" & vbTab & Text(30) & vbCrLf
    Msg = Msg & " #" & vbTab & Text(31) & vbCrLf
    Msg = Msg & " >" & vbTab & Text(32) & vbCrLf
    Msg = Msg & " <" & vbTab & Text(33) & vbCrLf
    Msg = Msg & " >=" & vbTab & Text(34) & vbCrLf
    Msg = Msg & " <=" & vbTab & Text(35) & vbCrLf
    Msg = Msg & " <>" & vbTab & Text(36) & vbCrLf
    MsgBox Msg, vbInformation, APPNAME
    End Sub

    Private Sub ClearCriteriaButton_Click()
    'Clears all of the criteria boxes
    Dim ctl As Control
    For Each ctl In Frame2.Controls
    If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then
    ctl.Text = ""
    End If
    Next ctl
    MultiPage1.page2.Caption = Text(3)
    End Sub

    Private Sub HelpButton_Click()
    'Displays the "about box"
    FormAbout.Show
    End Sub

    Private Sub TranslateText(LanguageColumn)
    'Reads the text items for the Form
    Dim r As Long
    For r = 1 To 36
    Text(r) = ThisWorkbook.Sheets("Sheet1").Cells(r, LanguageColumn)
    Next r
    If LanguageColumn <> 1 Then
    Me.Caption = Text(1)
    MultiPage1.Pages(0).Caption = Text(2)
    MultiPage1.Pages(1).Caption = Text(3)
    NewButton.Caption = Text(4)
    InsertButton.Caption = Text(5)
    DeleteButton.Caption = Text(6)
    FindPreviousButton.Caption = Text(7)
    FindNextButton.Caption = Text(8)
    UndoButton.Caption = Text(11)
    CloseButton.Caption = Text(12)
    ClearCriteriaButton.Caption = Text(13)
    TipsButton.Caption = Text(14)
    End If
    End Sub

    Private Function UserHeight()
    'Returns the height value for the Form
    Dim Ht As Long
    UserHeight = Me.Height
    On Error Resume Next
    Ht = Evaluate(ActiveWorkbook.Names("DF_HEIGHT").Value)
    If Err.Number = 0 Then
    If Ht > Me.Height Then UserHeight = Ht
    End If
    End Function

    Private Function UserWidth()
    'Returns the width value for the Form
    Dim Wid As Long
    UserWidth = Me.Width
    On Error Resume Next
    Wid = Evaluate(ActiveWorkbook.Names("DF_WIDTH").Value)
    If Err.Number = 0 Then
    If Wid > Me.Width Then UserWidth = Wid
    End If
    End Function

    Function NameHasData(n) As Boolean
    'Returns True if a defined name (n) contains data
    'This is used to determine if the field should display as a ComboBox
    Dim x As Range
    NameHasData = False
    On Error Resume Next
    Set x = Range(Evaluate(ActiveWorkbook.Names(n).RefersTo).Address)
    If Err.Number = 0 Then
    If Application.CountA(x) <> 0 Then NameHasData = True
    End If
    End Function
    Function UNIQUEITEMS(ArrayIn) As Variant
    Dim NoDupes As New Collection
    Dim OutArray() As Variant
    Dim Cell As Range, i As Long
    Set ArrayIn = Intersect(ArrayIn, ArrayIn.Parent.UsedRange)
    On Error Resume Next ''avoid error when adding duplicated item to collection
    For Each Cell In ArrayIn
    If Not IsEmpty(Cell) And Not IsError(Cell) Then NoDupes.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    If NoDupes.Count = 0 Then
    UNIQUEITEMS = Nothing
    Else
    ReDim OutArray(1 To NoDupes.Count)
    For i = 1 To NoDupes.Count
    OutArray(i) = NoDupes(i)
    Next i
    UNIQUEITEMS = OutArray
    End If
    End Function

    Các bạn có thể áp dụng kỹ thuật của Data form này rất hay !!!
    Chúc các bạn thành công và tìm được điều mình mong muốn.
    Lê Văn Duyệt
    levanduyet@yahoo.com
     
    #4
  5. Lê Quang Huy

    Lê Quang Huy Thành viên hoạt động

    Bài viết:
    6
    Đã được thích:
    0
    Nơi ở:
    HCMC
    Mình hơi dốt một chút nhưng nghe bạn bác nói chắc có vẻ hay lắm. Vậy Bác có thể hướng dẫn chi tiết hơn được không? Làm sao để cái form này nó hoặt động được? Chep máy cái code và mấy cái data form ở trên vào đâu? Làm phiền bác chỉ giúp mình nhé.

    Cám ơn bá ... E mail: kimlan@saigonnet.vn
     
    #5
  6. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    Chào bạn,
    Đây là phần Add-in. Nên bạn chỉ việc download về và bung ra là sử dụng được. Đoạn code chỉ để cho các bạn tham khảo, học tập thôi !
    Lê Văn Duyệt
     
    #6
  7. nguoiconxunui

    nguoiconxunui Khách vãng lai

    Bài viết:
    1,256
    Đã được thích:
    219
    Nơi ở:
    Bình Định
    Bạn nên đọc cái này và mò thêm nha!
    Chúc bạn thành công!
     
    #7
  8. DucThuan

    DucThuan Tè lè ra rồi !

    Bài viết:
    173
    Đã được thích:
    4
    Nơi ở:
    Đầu đường xó chợ
    Tôi đã làm như anh đã hướng dẫn, nhưng chỉ thấy 2 sheet trống thôi, tôi không hiểu cách sử dụng.
    Cám ơn.
    tsf264@yahoo.com
     
    #8
  9. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    Chào bạn tsf,
    Bạn đã bao giờ sử dụng một add-in nào chưa? Đây là phần add-in nhằm giúp bạn nhập dữ liệu. Khi bạn cài add-in vào sẽ có thêm một mục trong menu (Tools hay Data gì đó, xin lỗi tôi không nhớ rõ!). Khi bạn cần nhập dữ liệu bạn chỉ cần chọn một ô trong vùng dữ liệu, rồi sau đó chọn menu được thêm vào ở trên.
    Chúc bạn thành công.
    Lê Văn Duyệt
    levanduyet@yahoo.com
    levanduyet@gmail.com
     
    #9
  10. hoang1976

    hoang1976 Thành viên sơ cấp

    Bài viết:
    34
    Đã được thích:
    0
    Nơi ở:
    Hanoi
    Troi oi, hap dan qua, su dung form trong excel?? code hay, ban lam on chi gium cach su ly khi minh da coppy doan code vao excell roi thi phai lam nhu the nao di, lam on chi gium bang tieng viet y.
    Giup nguoi thi giup cho chot...
    Minh hy vong ban gui cho minh cach lam the nao de cac macro, modoule hoac code co the hoat dong duoc nhe: ngannganganngo@yahoo.com
     
    #10
  11. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    Bạn cứ vào đường link mà download về xài.
    Chúc bạn thành công.
    Lê Văn Duyệt
     
    #11

Chia sẻ trang này