Data Form Ver 2.0

[levanduyet]

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

 

[levanduyet]

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

 

[levanduyet]

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

 

[levanduyet]

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

 

[Lê Quang Huy]

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

 

[levanduyet]

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

 

[nguoiconxunui]

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

Bạn nên đọc cái này và mò thêm nha!

Download and Install
The J-Walk Enhanced Data Form is a standard Excel add-in file. It does not use any custom DLLs, and it makes no changes to your system.

To install the add-in:

Download the J-Walk Enhanced Data Form v2 add-in (352K).
This is an EXE file that creates the dataform2.xla add-in file. This file can be stored anywhere on your system.
Start Excel 97 or later.
Select Add-Ins from the Tools menu. This command is not available if a workbook is not visible.
In the Add-Ins dialog box, click the Browse button.
Locate the dataform2.xla file (the file you extracted in Step #1)
After performing these steps, Excel's Data menu will display a new menu item: J-Walk Enhanced Data Form. The add-in will be available for all future Excel sessions.

Uninstall
To uninstall the add-in, choose Add-Ins from the Tools menu, and remove the checkmark from the 'Enhanced Data Form v2' item.

After performing this step, the dataform2.xla add-in will not be loaded when Excel starts.

Chúc bạn thành công!

 

[DucThuan]

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

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

 

[levanduyet]

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

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

 

[hoang1976]

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

 

[levanduyet]

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

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