Page 1 of 2

ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Thu Mar 16, 2017 10:10 am
by rich37
ช่วยปรับ codeให้ค้นหาคอลัมน์ B แทน คอลัมน์ A และให้ TextBox1 สามารถรับค่าเพื่อค้นหาและเพิ่มข้อมูลได้
ณ ตอนนี้หากกดค้นหาโดยใส่เป็นเลขลำดับจะเป็นการค้นหาแต่หากใส่หมายเลขคดีจะไม่มีการค้นหาใดๆเลย โดยคอลัมน์ A ซึ่งเป็นลำดับ ไม่ใช่หมายเลขคดีอย่างที่ต้องการ รบกวนด้วยครับ

Code: Select all

Private Sub CommandButton1_Click()
On Error Resume Next
Dim myRange As Range
    Set myRange = Worksheets("Database").Range("_Data")
On Error Resume Next
        TextBox2.Value = _
        Application.WorksheetFunction.VLookup(--(TextBox1.Value), myRange, 3, False)
        TextBox3.Value = _
        Application.WorksheetFunction.VLookup(--(TextBox1.Value), myRange, 4, False)
        TextBox4.Value = _
        Application.WorksheetFunction.VLookup(--(TextBox1.Value), myRange, 5, False)
        TextBox5.Value = _
        Application.WorksheetFunction.VLookup(--(TextBox1.Value), myRange, 6, False)
        TextBox6.Value = _
        Application.WorksheetFunction.VLookup(--(TextBox1.Value), myRange, 7, False)
        ComboBox1.Value = _
        Application.WorksheetFunction.VLookup(--(TextBox1.Value), myRange, 8, False)
        ComboBox2.Value = _
        Application.WorksheetFunction.VLookup(--(TextBox1.Value), myRange, 9, False)
End Sub

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Thu Mar 16, 2017 11:23 am
by DhitiBank
ลองแบบนี้ครับ

1. ปรับสูตร range name ชื่อ _Data เป็น
=OFFSET(Database!$A$1,1,1,COUNTA(Database!$A:$A)-1,COUNTA(Database!$1:$1)-1)

2. ปรับโค้ดในส่วนที่เป็น Vlookup นิดหน่อยครับ
จากเดิม
Application.WorksheetFunction.VLookup([color=#FF0000]--([/color]TextBox1.Value[color=#FF0000])[/color], myRange, 3, False)
เป็น
Application.WorksheetFunction.VLookup(TextBox1.Value, myRange, 3, False)
เอาออกให้หมด แล้วลองรันโค้ดดูใหม่ครับ

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Thu Mar 16, 2017 11:41 am
by puriwutpokin
ตาม คุณDhitiBank ให้เปลี่ยนลำดับการค้นหาตามกันไปด้วย

Code: Select all

Application.WorksheetFunction.VLookup(TextBox1.Value, myRange,3, False)
เป็น

Code: Select all

Application.WorksheetFunction.VLookup(TextBox1.Value, myRange,2, False)
รันลดไปเรื่อยนะครับ 4 เป็น 3 และตัวต่อไปด้วยครับ

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Thu Mar 16, 2017 11:49 am
by rich37
DhitiBank wrote:ลองแบบนี้ครับ

1. ปรับสูตร range name ชื่อ _Data เป็น
=OFFSET(Database!$A$1,1,1,COUNTA(Database!$A:$A)-1,COUNTA(Database!$1:$1)-1)

2. ปรับโค้ดในส่วนที่เป็น Vlookup นิดหน่อยครับ
จากเดิม
Application.WorksheetFunction.VLookup([color=#FF0000]--([/color]TextBox1.Value[color=#FF0000])[/color], myRange, 3, False)
เป็น
Application.WorksheetFunction.VLookup(TextBox1.Value, myRange, 3, False)
เอาออกให้หมด แล้วลองรันโค้ดดูใหม่ครับ
ขอบคุณครับ ลองปรับแล้วใช้งานได้ครับ ในส่วนหากต้องการเพิ่มข้อมูลหรือแก้ไขข้อมูลจกาที่ค้นหาหรือเพิ่มใหม่ควรปรับแก้อย่างไรครับ

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Thu Mar 16, 2017 11:52 am
by rich37
puriwutpokin wrote:ตาม คุณDhitiBank ให้เปลี่ยนลำดับการค้นหาตามกันไปด้วย

Code: Select all

Application.WorksheetFunction.VLookup(TextBox1.Value, myRange,3, False)
เป็น

Code: Select all

Application.WorksheetFunction.VLookup(TextBox1.Value, myRange,2, False)
รันลดไปเรื่อยนะครับ 4 เป็น 3 และตัวต่อไปด้วยครับ
ปรับแล้วใช้ได้ครับ ขอบคุณครับ แต่ติดปัญหาใหม่ครับว่าจะกดเพิ่มข็อมูลหรือกดเพื่อแก้ไขบางรายการที่ค้นหามาแล้วให้กลับไปไว้ที่จุดที่ค้นหาออกมาครับ

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Thu Mar 16, 2017 1:17 pm
by puriwutpokin
ลองดูตามไฟล์แนบครับติดตรงไหนค่อยมาดูกันอีกทีครับ

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Thu Mar 16, 2017 2:00 pm
by rich37
puriwutpokin wrote:ลองดูตามไฟล์แนบครับติดตรงไหนค่อยมาดูกันอีกทีครับ
ขอบคุณมากๆครับ ขอทดสอบดูก่อนนะครับ

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Thu Mar 16, 2017 2:16 pm
by puriwutpokin
หรือทำเป็นปุ๋มเดียวก็ปรับตามโค้ดนี้ครับใช้ฟอร์มเดิมครับ

Code: Select all

Private Sub CommandButton2_Click()
Dim icolumn  As Long
Dim iRow As Long
    Dim ws As Worksheet
    Set ws = Worksheets("Database")
    'find first empty row in database
    icolumn = ws.Cells(Rows.Count, 2) _
        .End(xlUp).Offset(1, 0).Row
    'Check for Id
    If Trim(Me.TextBox1.Value) = "" Then
        Me.TextBox1.SetFocus
        MsgBox "คุณยังไม่ได้ใส่ข้อมูล"
        Exit Sub
        Else
          If Application.CountIf(ws.Range("B2:B10000"), Trim(Me.TextBox1.Value)) = 0 Then
    'copy the data to the database
    ws.Cells(icolumn, 2).Value = Me.TextBox1.Value
    ws.Cells(icolumn, 3).Value = Me.TextBox2.Value
    ws.Cells(icolumn, 4).Value = Me.TextBox3.Value
    ws.Cells(icolumn, 5).Value = Me.TextBox4.Value
    ws.Cells(icolumn, 6).Value = Me.TextBox5.Value
    ws.Cells(icolumn, 7).Value = Me.TextBox6.Value
    ws.Cells(icolumn, 8).Value = Me.ComboBox1.Value
    ws.Cells(icolumn, 9).Value = Me.ComboBox2.Value
    'Clear the data
    Me.TextBox1.Value = ""
    Me.TextBox2.Value = ""
    Me.TextBox3.Value = ""
    Me.TextBox4.Value = ""
    Me.TextBox5.Value = ""
    Me.TextBox6.Value = ""
    Me.ComboBox1.Value = ""
    Me.ComboBox2.Value = ""
    Me.TextBox1.SetFocus
    MsgBox "เพิ่มข้อมูลเรียบร้อย"
    Else
        If Trim(Me.TextBox1.Value) = "" Then
        MsgBox "คุณยังไม่ได้ใส่ข้อมูล"
        Exit Sub
Else
        iRow = _
        Application.WorksheetFunction.Match(TextBox1.Value, ws.Range("B2:B10000"), 0) + 1
    ws.Cells(iRow, 2).Value = Me.TextBox1.Value
    ws.Cells(iRow, 3).Value = Me.TextBox2.Value
    ws.Cells(iRow, 4).Value = Me.TextBox3.Value
    ws.Cells(iRow, 5).Value = Me.TextBox4.Value
    ws.Cells(iRow, 6).Value = Me.TextBox5.Value
    ws.Cells(iRow, 7).Value = Me.TextBox6.Value
    ws.Cells(iRow, 8).Value = Me.ComboBox1.Value
    ws.Cells(iRow, 9).Value = Me.ComboBox2.Value
    'Clear the data
    Me.TextBox1.Value = ""
    Me.TextBox2.Value = ""
    Me.TextBox3.Value = ""
    Me.TextBox4.Value = ""
    Me.TextBox5.Value = ""
    Me.TextBox6.Value = ""
    Me.ComboBox1.Value = ""
    Me.ComboBox2.Value = ""
    Me.TextBox1.SetFocus
    MsgBox "แก้ไขข้อมูลเรียบร้อย"
     End If
       End If
         End If
  End Sub

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Thu Mar 16, 2017 2:53 pm
by rich37
puriwutpokin wrote:หรือทำเป็นปุ๋มเดียวก็ปรับตามโค้ดนี้ครับใช้ฟอร์มเดิมครับ

Code: Select all

Private Sub CommandButton2_Click()
Dim icolumn  As Long
Dim iRow As Long
    Dim ws As Worksheet
    Set ws = Worksheets("Database")
    'find first empty row in database
    icolumn = ws.Cells(Rows.Count, 2) _
        .End(xlUp).Offset(1, 0).Row
    'Check for Id
    If Trim(Me.TextBox1.Value) = "" Then
        Me.TextBox1.SetFocus
        MsgBox "คุณยังไม่ได้ใส่ข้อมูล"
        Exit Sub
        Else
          If Application.CountIf(ws.Range("B2:B10000"), Trim(Me.TextBox1.Value)) = 0 Then
    'copy the data to the database
    ws.Cells(icolumn, 2).Value = Me.TextBox1.Value
    ws.Cells(icolumn, 3).Value = Me.TextBox2.Value
    ws.Cells(icolumn, 4).Value = Me.TextBox3.Value
    ws.Cells(icolumn, 5).Value = Me.TextBox4.Value
    ws.Cells(icolumn, 6).Value = Me.TextBox5.Value
    ws.Cells(icolumn, 7).Value = Me.TextBox6.Value
    ws.Cells(icolumn, 8).Value = Me.ComboBox1.Value
    ws.Cells(icolumn, 9).Value = Me.ComboBox2.Value
    'Clear the data
    Me.TextBox1.Value = ""
    Me.TextBox2.Value = ""
    Me.TextBox3.Value = ""
    Me.TextBox4.Value = ""
    Me.TextBox5.Value = ""
    Me.TextBox6.Value = ""
    Me.ComboBox1.Value = ""
    Me.ComboBox2.Value = ""
    Me.TextBox1.SetFocus
    MsgBox "เพิ่มข้อมูลเรียบร้อย"
    Else
        If Trim(Me.TextBox1.Value) = "" Then
        MsgBox "คุณยังไม่ได้ใส่ข้อมูล"
        Exit Sub
Else
        iRow = _
        Application.WorksheetFunction.Match(TextBox1.Value, ws.Range("B2:B10000"), 0) + 1
    ws.Cells(iRow, 2).Value = Me.TextBox1.Value
    ws.Cells(iRow, 3).Value = Me.TextBox2.Value
    ws.Cells(iRow, 4).Value = Me.TextBox3.Value
    ws.Cells(iRow, 5).Value = Me.TextBox4.Value
    ws.Cells(iRow, 6).Value = Me.TextBox5.Value
    ws.Cells(iRow, 7).Value = Me.TextBox6.Value
    ws.Cells(iRow, 8).Value = Me.ComboBox1.Value
    ws.Cells(iRow, 9).Value = Me.ComboBox2.Value
    'Clear the data
    Me.TextBox1.Value = ""
    Me.TextBox2.Value = ""
    Me.TextBox3.Value = ""
    Me.TextBox4.Value = ""
    Me.TextBox5.Value = ""
    Me.TextBox6.Value = ""
    Me.ComboBox1.Value = ""
    Me.ComboBox2.Value = ""
    Me.TextBox1.SetFocus
    MsgBox "แก้ไขข้อมูลเรียบร้อย"
     End If
       End If
         End If
  End Sub
ถ้าเราจะเพิ่มกล่องรับวันที่ ที่เราจัดเก็บข้อมูลเข้าไปสามารถเพิ่มได้ไหมครับ

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Thu Mar 16, 2017 3:05 pm
by puriwutpokin
ก็ทำได้เมื่อ TextBox อื่นๆครับ ลองเขียนมาดูก่อนครับ ติดขัดแล้วค่อยมาถามกันใหม่ครับ

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Thu Mar 16, 2017 3:06 pm
by rich37
puriwutpokin wrote:ก็ทำได้เมื่อ TextBox อื่นๆครับ ลองเขียนมาดูก่อนครับ ติดขัดแล้วค่อยมาถามกันใหม่ครับ
ขอบคุณครับลองปรับใส่วันที่แล้ว ได้ผลตามต้องการครับ แต่ติดปัญหาตรงที่ใน Textbox7 จะโชว์วันที่ในรูปแบบที่เป็นตัวเลข แบบนี้ครับ 241136 ซึ่งค่าในชีต Database คือ 15 มีนาคม 2560 ( พิมพ์ 15/3/2017) แก้แบบไหนดีครับ

Code: Select all

Private Sub UserForm_Initialize()
TextBox7.Value = Format(Date, "dd mmmm yyyy")
A = "Person!_Type"
ComboBox1.RowSource = A
B = "Person!_Person"
ComboBox2.RowSource = B
End Sub

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Sat Mar 18, 2017 8:16 am
by rich37
หากต้องการเปลี่ยนการค้นหาให้สามารถค้นหาได้ทั้งหมด ใน Worksheets("Database")ควรจะแก้ไขอย่างไรดีครับ

Code: Select all

Private Sub CommandButton2_Click()
Dim icolumn  As Long
Dim iRow As Long
    Dim ws As Worksheet
    Set ws = Worksheets("Database")
    'find first empty row in database
    icolumn = ws.Cells(Rows.Count, 2) _
        .End(xlUp).Offset(1, 0).Row
    'Check for Id
    If Trim(Me.TextBox1.Value) = "" Then
        Me.TextBox1.SetFocus
        MsgBox "คุณยังไม่ได้ใส่ข้อมูล"
        Exit Sub
        Else
          If Application.CountIf(ws.Range("B2:B10000"), Trim(Me.TextBox1.Value)) = 0 Then
    'copy the data to the database
    ws.Cells(icolumn, 2).Value = Me.TextBox1.Value
    ws.Cells(icolumn, 3).Value = Me.TextBox2.Value
    ws.Cells(icolumn, 4).Value = Me.TextBox3.Value
    ws.Cells(icolumn, 5).Value = Me.TextBox4.Value
    ws.Cells(icolumn, 6).Value = Me.TextBox5.Value
    ws.Cells(icolumn, 7).Value = Me.TextBox6.Value
    ws.Cells(icolumn, 8).Value = Me.ComboBox1.Value
    ws.Cells(icolumn, 9).Value = Me.ComboBox2.Value
    'Clear the data
    Me.TextBox1.Value = ""
    Me.TextBox2.Value = ""
    Me.TextBox3.Value = ""
    Me.TextBox4.Value = ""
    Me.TextBox5.Value = ""
    Me.TextBox6.Value = ""
    Me.ComboBox1.Value = ""
    Me.ComboBox2.Value = ""
    Me.TextBox1.SetFocus
    MsgBox "เพิ่มข้อมูลเรียบร้อย"
    Else
        If Trim(Me.TextBox1.Value) = "" Then
        MsgBox "คุณยังไม่ได้ใส่ข้อมูล"
        Exit Sub
Else
        iRow = _
        Application.WorksheetFunction.Match(TextBox1.Value, ws.Range("B2:B10000"), 0) + 1
    ws.Cells(iRow, 2).Value = Me.TextBox1.Value
    ws.Cells(iRow, 3).Value = Me.TextBox2.Value
    ws.Cells(iRow, 4).Value = Me.TextBox3.Value
    ws.Cells(iRow, 5).Value = Me.TextBox4.Value
    ws.Cells(iRow, 6).Value = Me.TextBox5.Value
    ws.Cells(iRow, 7).Value = Me.TextBox6.Value
    ws.Cells(iRow, 8).Value = Me.ComboBox1.Value
    ws.Cells(iRow, 9).Value = Me.ComboBox2.Value
    'Clear the data
    Me.TextBox1.Value = ""
    Me.TextBox2.Value = ""
    Me.TextBox3.Value = ""
    Me.TextBox4.Value = ""
    Me.TextBox5.Value = ""
    Me.TextBox6.Value = ""
    Me.ComboBox1.Value = ""
    Me.ComboBox2.Value = ""
    Me.TextBox1.SetFocus
    MsgBox "แก้ไขข้อมูลเรียบร้อย"
     End If
       End If
         End If
  End Sub

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Sat Mar 18, 2017 9:32 am
by puriwutpokin
แนบไฟล์ล่าสุดมาดู ครับจะได้เข้าใจตรงกันครับ

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Sat Mar 18, 2017 9:36 am
by rich37
puriwutpokin wrote:แนบไฟล์ล่าสุดมาดู ครับจะได้เข้าใจตรงกันครับ
ได้แนบไฟล์มาแล้วครับ และหากต้องการให้กดค้นหาแล้วไม่พบข้อมูลให้ MsgBox ขึ้นว่าไม่พบข้อมูลด้วยผมลองแล้วไม่สามารถทำได้ครับ

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Sat Mar 18, 2017 10:35 am
by puriwutpokin

Code: Select all

...Other code
    If Trim(Me.TextBox1.Value) = "" Then
        Me.TextBox1.SetFocus
        ...Other code

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Sat Mar 18, 2017 10:44 am
by rich37
puriwutpokin wrote:

Code: Select all

...Other code
    If Trim(Me.TextBox1.Value) = "" Then
        Me.TextBox1.SetFocus
        ...Other code
ค่าใน Textbox1 ไม่ว่างนี่สิครับเพราะเราใส่คำเข้าไปให้ค้นหา

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Sat Mar 18, 2017 10:57 am
by puriwutpokin

Code: Select all

...Other code
If Trim(Me.TextBox1.Value) = "" Or Application.CountIf(ws.Range("B2:B10000"), Trim(Me.TextBox1.Value)) = 0 Then
...Other code

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Sat Mar 18, 2017 11:09 am
by rich37
puriwutpokin wrote:

Code: Select all

...Other code
If Trim(Me.TextBox1.Value) = "" Or Application.CountIf(ws.Range("B2:B10000"), Trim(Me.TextBox1.Value)) = 0 Then
...Other code
ผลออกมาว่า การค้นหา ไม่พบทั้งหมดเลย ทั้งๆที่ข้อมูลมีครับ
ตามไฟล์รูปแนบครับ

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Sat Mar 18, 2017 11:10 am
by puriwutpokin
แก้ไขโค้ดครับ

Code: Select all

...other code On Error Resume Next
    Dim ws As Worksheet
    Set ws = Worksheets("Database")
Dim myRange As Range
    Set myRange = Worksheets("Database").Range("_Data")
    If Application.CountIf(ws.Range("B2:B10000"), Trim(Me.TextBox1.Value)) = 0 Then
        Me.TextBox1.SetFocus
        MsgBox "ไม่พบข้อมูล", vbInformation, "ระบบค้นหาสำนวน"
        Exit Sub...other code

Re: ช่วยปรับ codeให้ค้นหาคอลัมน์

Posted: Sat Mar 18, 2017 11:19 am
by rich37
puriwutpokin wrote:แก้ไขโค้ดครับ

Code: Select all

...other code On Error Resume Next
    Dim ws As Worksheet
    Set ws = Worksheets("Database")
Dim myRange As Range
    Set myRange = Worksheets("Database").Range("_Data")
    If Application.CountIf(ws.Range("B2:B10000"), Trim(Me.TextBox1.Value)) = 0 Then
        Me.TextBox1.SetFocus
        MsgBox "ไม่พบข้อมูล", vbInformation, "ระบบค้นหาสำนวน"
        Exit Sub...other code
ใช้ได้แล้วครับขึ้นโชว์ข้อความตามที่ต้องการ ขอบคุณครับ
และหากต้องการเปลี่ยนการค้นหาให้สามารถค้นหาได้ทั้งหมด ใน Worksheets("Database") โดยการที่จะให้พิมพ์ค่าไหนก็ได้ลงใน Textbox1โดยไม่จำกัดเฉพาะว่าเป็นหมายเลขคดีแดง สามารถทำได้ไหมครับ ช่วยแนะนำด้วยครับ