Excel Forum

Code: Select all

Sub FindRecords()
Dim lng As Long, rs As Range, rt As Range
With Worksheets("Sheet1")
On Error Resume Next
    lng = Application.Match(.Range("F4"), .Range("A:A"), 0)
    Set rs = .Range("A" & lng).Resize(, 4)
    Set rt = .Range("F4")
End With
    If Err > 0 Then
        MsgBox "Not found"
        Exit Sub
    Else
        rs.Copy: rt.PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End If
End Sub

Sub AddRecords()
Dim rs As Range, rt As Range
With Worksheets("Sheet1")
    Set rs = .Range("F4:I4")
    Set rt = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End With
    rs.Copy: rt.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End Sub

Sub UpdateRecords()
Dim lng As Long, rs As Range, rt As Range
With Worksheets("Sheet1")
On Error Resume Next
    lng = Application.Match(.Range("F4"), .Range("A:A"), 0)
    Set rt = .Range("A" & lng)
    Set rs = .Range("F4:I4")
End With
    If Err > 0 Then
        MsgBox "Not found"
        Exit Sub
    Else
        rs.Copy: rt.PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End If
End Sub

Code: Select all

Private Sub ComboBox1_Change()
On Error Resume Next
Set myRange = Worksheets("Sheet1").Range("A2:D30")
    TextBox5.Value = Application.WorksheetFunction.VLookup(CLng(ComboBox1), myRange, 1, False)
    TextBox2.Value = Application.WorksheetFunction.VLookup(CLng(ComboBox1), myRange, 2, False)
    TextBox3.Value = Application.WorksheetFunction.VLookup(CLng(ComboBox1), myRange, 3, False)
    TextBox3 = Application.Text(TextBox3, "dd/mm/bbbb") 'ตัวเลขในเซลล์ควรเก็บเป็นค.ศ.
    TextBox4.Value = Application.WorksheetFunction.VLookup(CLng(ComboBox1), myRange, 4, False)
    TextBox4 = Format(TextBox4, "000-0000-000")
    'Range("C8") = DateValue(TextBox3) 'ตัวอย่างการนำค่าใน TextBox3 ไปวางกลับในเซลล์ C8 ให้เป็นค.ศ.เหมือนเดิม
If Err <> 0 Then
    MsgBox "ไม่มีรายการที่ท่านเลือก", vbQuestion
    TextBox2.Text = ""
    TextBox3.Text = ""
    TextBox4.Text = ""
    TextBox5.Text = ""
    Exit Sub
End If
End Sub

Code: Select all

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim wb As Variant
Dim rt As Range
Dim rs As Range
Dim myData As Range
Dim key As Object 'Dim key As Range กรณีที่แรงเนมที่เราอ้างถึงมีสูตรอยู่ควรประกาศตัวแปรเป็นอะไรครับ
Sheet1.Range("A3:Z3").Value = Sheet1.Range("A2:Z2").Value
If txtnum.Value = "" Then
MsgBox "กดผมทำไม เจ็บนะ", vbQuestion, "BES 4U"
TextBox1.Value = ""
Exit Sub
End If
Set wb = Workbooks.Open("C:\Program Files\BES 4U\DATA\base\data.xls", False, False)
ActiveWorkbook.Worksheets("tblcustom").Select
With Workbooks("data.xls").Worksheets("tblcustom")
Set rs = Workbooks("data.xls").Worksheets("tblcustom").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Set myData = Workbooks("data.xls").Worksheets("tblcustom").Range("A:Z")
Set key = Workbooks("data.xls").Worksheets("tblcustom").Range("AB1") 'เดิมทีเขียน Set key =Workbooks("data.xls").Worksheets("tblcustom").Range("AB1")CountIf(.Range("A:A"), .Range("AB1"))
End With
With Workbooks("BES 4U.xls").Worksheets("master")
Set rt = Workbooks("BES 4U.xls").Worksheets("master").Range("A3:Z3")
End With
On Error Resume Next
If key = "Active" Then 'เดิม If Key = "Active" then (ผมกำหนดค่าที่AB2=IF(COUNTIF(A:A,AB1)>=1,"Active","In Active")
wb.Close True
Application.ScreenUpdating = False
MsgBox "มีข้อมูลบุคคลท่านนี้แล้วครับ", vbOKOnly, "BES 4U"
Else
rt.Copy: rs.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    
  Workbooks("data.xls").Worksheets("tblcustom").Activate
     myData.Select
    Selection.Sort Key1:=myData, Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
   wb.Close True
MsgBox "บันทึกสำเร็จครับ", vbOKOnly, "BES 4U"
Application.ScreenUpdating = True
End If
If Err > 0 Then
Exit Sub
End If

End Sub

Code: Select all

Private Sub UserForm_Initialize()
    ListBox1.RowSource = "'[Book1.xlsx]Sheet1'!A2:A13"
End Sub