การแสดงข้อมูลที่ Filter

[Bafnet]

สวัสดีครับอาจารย์ มาทีไรก็นำปัญหามาสู่อาจารย์
อาจารย์ครับผมเขียนคำสั่งเพื่อกรองข้อมูลสัญญาของลูกค้าที่เราระบุ ซึ่งบางคนอาจมีแค่1 หรือ30 สัญญา แล้วนำผลกรองไปแสดงที่Listbox
ปัญหาแรกคือหากกำหนดที่ListBoxให้ Rowsource Propeties : FileB!A:S
ผลที่ได้คือListBox แสดงข้อมูลในชีทFileB ทั้งหมดแม้หน้านั้นจะผ่านคำสั่งกรองข้อมูลแล้ว
ผมเลยแก้ปัญหาโดยการเพิ่มคำสั่งให้ Coppy ชีทFileB ที่แสดงผลการกรองแล้วไปวางที่อีกชีทหนึ่ง(ชื่อชีท Coplone) แล้วกำหนดกำหนดที่ListBoxให้ Rowsource Propeties : Coplone!A1:S100
เพื่อให้ListBox แสดงค่าที่ผ่านการกรองแล้ว คำสั่งดังนี้ครับ
Private Sub CommandButton6_Click() 'ค้นหาลูกค้า
Dim lng As Long, rs As Range, rt As Range
Dim ry As Range
Dim ri As Range
Dim cri As String
Sheet9.Activate
Sheet9.Range("A:S").AutoFilter Field:=3
With Worksheets("FileA")
On Error Resume Next
lng = Application.Match(Sheet15.Range("A1"), .Range("A:A"), 0)
Set rs = .Range("A" & lng).Resize(, 21)
Set rt = Sheet15.Range("A3")
End With
If Err > 0 Then
MsgBox "ไม่พบข้อมูล อาจเป็นลูกค้าใหม่" & vbCrLf & "ท่านต้องสร้างทะเบียนใหม่ด้วยตัวเอง หรือโหลด PALM ใหม่", vbOKOnly, "DumP"
Else
rs.Copy: rt.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Rep.Rep
Application.ScreenUpdating = True
End If
With Workbooks("DumP.xlsm").Worksheets("FileB") ชีทที่เป็นตารางสัญญากู้
Set ri = Workbooks("DumP.xlsm").Worksheets("FileB").Range("A:S")
cri = Sheet15.Range("A1").Value 'เงื่อนไขการกรองเลขทะเบียนลูกค้า
End With
With Workbooks("DumP.xlsm").Worksheets("Coplone") ' ชีทที่ให้วางCoppy ผลจากการกรอง
Set ry = Workbooks("DumP.xlsm").Worksheets("Coplone").Range("A:S")
End With
Sheet9.Activate
Sheet9.Range("A:S").AutoFilter Field:=3, Criteria1:=cri
ri.Copy: ry.PasteSpecial xlPasteValues 'เพื่อให้แสดงข้อมูลที่ผ่านการกรอง
Application.CutCopyMode = False
Application.ScreenUpdating = True If Err > 0 Then
Exit Sub
End If
End Sub
อาจารย์ครับทุกอย่างได้ผลอย่างต้องการครับ แต่ไม่น่าพอใจครับ รู้สึกว่าช้าเพราะคำสั่งCoppyหน้าที่กรองนั้น
เวลามันCoppyมันCoppy ทั้งชีทแม้เราจะเห็นข้อมูลแค่ส่วนที่กรอง
มีวิธีการไหนบ้างครับที่ให้Coppy หรือส่งข้อมูลไปเฉพาะค่าที่ผ่านการกรองแล้ว
หรือสามารถกำหนดให้ListBox แสดงค่าที่ผ่านการกรองแล้ว(ขั้นตอนต่อไปคือเมื่อผู้ใช้คลิ๊กเลือกสัญญาในlistBox ผมก็จะให้แสดงรายละเอียดของสัญญา งวดชำระต่อไป)

[snasui]

รายงานผลของกระทู้นี้ viewtopic.php?f=3&t=1311 ด้วยครับ ไม่ทราบว่าการ Delete Query ใช้ได้หรือไม่ครับ

การเขียนเนื้อหาคำถาม พยายามเว้นบรรทัดเมื่อขึ้นย่อหน้าใหม่เพื่อให้อ่านง่ายขึ้นกว่าเดิมด้วยครับ

[Bafnet]

ขออภัยด้วยครับ
อาจารย์ครับการDelete Query ได้ผลครับ คราวแรกรันใน2010 ราบรื่น
พอรันใน2003 เหมือนกับไม่ได้ผล ก็คิดว่าใน2003ไม่มีคุณลักษณะของtable
แต่ภายหลังก็ได้แล้วครับ ผมรบกวนถามสักนิดเมื่อพูดถึงประเด็นนี้แล้ว
ActiveSheet.QueryTables(1).Delete เลข(1)ในที่นี้หมายความว่าอย่างไรครับ
หมายถึงตารางที่1 ในชีทที่Active หรือครับ
ขอบคุณมากๆครับสำหรับทุกอย่าง คงต้องรบกวนอาจารย์อีกหลายๆประเด็น กว่างานชิ้นนี้จะเสร็จ
ตอนนี้เข้าสู่งานด้านสินเชื่อซึ่งค่อนข้างจะมีเงื่อนไขมากมาย ก็หวังงว่าคงจะเสร็จ
ขอบพระคุณอาจารย์อย่างสูง ทุกๆข้อแนะนำที่อาจารย์สอนมาผมนำไปเขียนเป็นบันทึกเก็บไว้...ขอบคุณมากๆครับ

[snasui]

การ Copy เฉพาะค่าที่ผ่านการกรอง ลองบันทึก Macro การกระทำดังนี้ครับ

1. คลิกปุ่มบันทึก Macro
2. กรองข้อมูล
3. คลุมคอลัมน์ที่มีการกรองข้อมูล > กดแป้น F5 > Special > Visible cells only > OK > Copy > วางที่ตำแหน่งปลายทาง
4. นำ Code Macro ไปปรับใช้

ดู Code ตัวอย่างที่นี่ครับ viewtopic.php?p=1156#p1156

[snasui]

ActiveSheet.QueryTables(1).Delete เลข(1)ในที่นี้หมายความว่าอย่างไรครับ

QueryTables คือ Collection ประกอบด้วย QueryTable หลาย ๆ ตัว เลข 1 คือตัวที่หนึ่ง หากเรามีการ Import ข้อมูลจากหลายแหล่งก็จะมีเลขมากตามจำนวนของ QueryTable ครับ หากมี QueryTable จำนวนมากและต้องการลบทั้งหมดก็ต้องใช้การ Loop เข้ามาช่วยครับ เช่น

Code: Select all

Dim qtb as QueryTable
For Each qtb in QueryTables
  qtb.Delete
Next qtb

[Bafnet]

ขอบคุณครับก็ได้ผลครับอาจารย์ ลองบันทึกมาโครตามที่อาจารย์แนะนำและไล่ดูตามกระทู้ที่อาจารย์ให้มา

Private Sub CommandButton6_Click()
Dim lng As Long, rs As Range, rt As Range
Dim ry As Range
Dim ri As Range
Dim cri As String
Sheet9.Activate
Sheet9.Range("A:S").AutoFilter Field:=3
With Worksheets("FileA")
On Error Resume Next
lng = Application.Match(Sheet15.Range("A1"), .Range("A:A"), 0)
Set rs = .Range("A" & lng).Resize(, 21)
Set rt = Sheet15.Range("A3")
End With
If Err > 0 Then
MsgBox "ไม่พบข้อมูลเลขทะเบียนที่ท่านระบุ", vbOKOnly, "DumP"
Else
rs.Copy: rt.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Rep.Rep สั่งรันโมดูลที่ชื่อ Rep
Application.ScreenUpdating = True
End If
With Workbooks("DumP.xlsm").Worksheets("FileB")
Set ri = Sheet9.Range("A1:S50").SpecialCells(xlCellTypeVisible)
cri = Sheet15.Range("A1").Value
End With
With Workbooks("DumP.xlsm").Worksheets("Coplone")
Set ry = Workbooks("DumP.xlsm").Worksheets("Coplone").Range("A1")
End With
Sheet9.Activate
Sheet9.Range("A:S").AutoFilter Field:=3, Criteria1:=cri
ri.Select
ri.Copy: ry.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
If Err > 0 Then
Exit Sub
End If
End Sub

อาจารย์ครับถามต่อสักนิดนะครับจากคำสั่งข้างต้น ผมได้ไปสั่งให้โมดูลที่ชื่อ Rep รัน
ซึ่งในคำสั่งของโมดูล Rep ก็จะมี On Error Resume Next และคำสั่ง
If Err >0 Then
Exit Sub
End If

คำถามคือ เราจะมีคำสั่งใดบ้างที่จะไปต่อท้ายคำสั่งรันโมดูล
เพื่อที่จะอ้างอิงว่าถ้าโมดูลที่เราสั่งรันนั้นถ้ามีผล Err >0 และ Exit Sub ไปแล้ว
ให้คำสั่งที่กำลังใช้นี้ Exit Sub เช่นกัน
Rep.Rep
If Modules("Rep").Value..... อันนี้ไปไม่เป็นแล้วครับ
รบกวนด้วยนะครับ พยายามเว้นบรรทัดแล้วครับ

[Bafnet]

มาอีกแล้วครับ...เผอิญนึกขึ้นได้
อาจารย์ครับผมเคยเห็นงานชิ้นหนึ่ง
บนUSERFORM เหมือนกับเขายุบหน้าชีท(ทั้งชีทเลยครับ รวมทั้งRipbon)
ไปแสดงอยู่บนฟอร์ม ซึ่งไม่แน่ใจว่าเป็นListBox หรือเครื่องมืออื่น แต่ผมคิดว่าไม่น่าจะใช่
เพราะบนฟอร์มดังกล่าวสามารถแก้ไขข้อมูลในเซลเหมือนกับว่าทำงานบนหน้าชีทปกติ เพียงแต่ไปแสดงบนUserForm
อีกชิ้นงานหนึ่งก็คล้ายกันครับ แต่เป็นการสั่งCommandbottom แล้วแสดงผลเป็นหน้า Web ที่สั่งกำหนดLinkไว้
สามารถที่จะทำการเหมือนหน้าเวปปกติ เพียงแต่หน้าเวปแสดงบนUSERFORM
พอจะแนะนำหรือให้รายละเอียดหน่อยได้ไหมครับ
ขอบคุณครับ

[snasui]

If Err > 0 Then
Exit Sub
End If
End Sub

กรณีหลังจาก Code ดังกล่าวเป็น End Sub ไม่ต้องใช้ If มาดักค่า Err ที่ไม่เป็น 0 ก็ได้ครับ เพราะมันก็ต้องจบ Procedure ด้วย End Sub อยู่แล้ว

การใช้ On Error Resume Next เพื่อจะให้ Code ทำงานต่อแม้ว่าจะมี Error เกิดขึ้น หากว่าต้องการตรวจสอบว่าใน Sub Code ที่นำมา Run ใช้ On Error... ไปแล้วหรือไม่ ก็ต้องเก็บค่าตัวแปรเพื่อเป็นเงื่อนไขให้กับ Main Procedure ครับ เมื่อออกจาก Sub Procedure แล้วก็มาเช็คว่าตัวแปรนั้นเข้าเงื่อนไขหรือไม่ ถ้าเข้าเงื่อนไขก็ให้ออกจาก Main Procedure ตามไปด้วย
ดูตัวอย่าง Code ด้านล่างครับ

Code: Select all

Dim v As Byte 'Declare v as module scope

Sub test0()
Dim t As Byte
t = InputBox("Enter data")
    Select Case t
        Case 1, 3, 5, 7
            test1
        Case 2, 4, 6, 8
            MsgBox t
    End Select
    If v <> 0 Then Exit Sub
    MsgBox "Finish"
End Sub

Sub test1()
    On Error Resume Next
    v = 1
    MsgBox "Wowwww"
End Sub

ถ้ากรอก 1, 3, 5, 7 ใน InputBox จะไม่แสดงคำว่า Finish ให้เห็น เพราะจะเรียก Sub Code ชื่อ Test1 ขึ้นมาและเรากำหนดตัวแปร V ไว้ ผมใช้หลักการง่าย ๆ คือถ้ามีการคีย์ On Error Resume Next ก็ให้แนบตัวแปร V ไปด้วยเสมอ ซึ่งแล้วแต่จะกำหนดให้มีค่าเป็นอะไร ในตัวอย่างผมกำหนดให้มีค่าเป็น 1

[snasui]

มาอีกแล้วครับ...เผอิญนึกขึ้นได้
อาจารย์ครับผมเคยเห็นงานชิ้นหนึ่ง
บนUSERFORM เหมือนกับเขายุบหน้าชีท(ทั้งชีทเลยครับ รวมทั้งRipbon)
ไปแสดงอยู่บนฟอร์ม ซึ่งไม่แน่ใจว่าเป็นListBox หรือเครื่องมืออื่น แต่ผมคิดว่าไม่น่าจะใช่
เพราะบนฟอร์มดังกล่าวสามารถแก้ไขข้อมูลในเซลเหมือนกับว่าทำงานบนหน้าชีทปกติ เพียงแต่ไปแสดงบนUserForm
อีกชิ้นงานหนึ่งก็คล้ายกันครับ แต่เป็นการสั่งCommandbottom แล้วแสดงผลเป็นหน้า Web ที่สั่งกำหนดLinkไว้
สามารถที่จะทำการเหมือนหน้าเวปปกติ เพียงแต่หน้าเวปแสดงบนUSERFORM
พอจะแนะนำหรือให้รายละเอียดหน่อยได้ไหมครับ
ขอบคุณครับ

คงต้องมีตัวอย่างมาให้เห็นครับ จะได้เดาต่อได้

[Bafnet]

สวัสดีครับอาจารย์ เรื่องการCoppyส่วนที่Filter
คราวที่แล้วทำไปทำมาผิดครับ
With Workbooks("DumP.xlsm").Worksheets("FileB")
Set ri = Sheet9.Range("A1:S50").SpecialCells(xlCellTypeVisible)
ไปกำหนดขอบเขตข้อมูลA1:S50 กลับไปทบทวนบทความที่อาจารย์แนะนำ จนได้แบบนี้

With Workbooks("DumP.xlsm").Worksheets("FileB")
Set ri = .Range(.Range("A1"), .Range("S65536") _
.End(xlUp)).SpecialCells(xlCellTypeVisible)
cri = Sheet15.Range("A1").Value
End With
ขอบคุณมากครับ

ถามต่อนะครับ ผมสร้างโมดูลที่ชื่อ Tolone คำสั่งดังนี้
Sub Tolone()
Dim r As Integer
Dim i As Single
Dim y As Single
Sheet9.Activate
Sheet9.Range("T1").Value = "หนี้รวม"
r = 2
Do Until Sheet9.Cells(r, 1).Value = ""
i = Sheet9.Cells(r, 12).Value(หนี้ปกติ)
y = Sheet9.Cells(r, 14).Value(หนี้ค้าง)
Sheet9.Cells(r, 20).Value = i + y
r = r + 1
Loop
End Sub

มันก็ใช้ไดผลครับ เฉพาะเมื่อเอาคำสั่งนี้ไปไว้ที่ Commandbutton
Private Sub CommandButton1_Click()
Tolone.Tolone
End Sub

แต่เมื่อนำโมดูลนี้ไปต่อท้ายในคำสั่งที่โหลดไฟล์Acess จากธนาคาร(ตั้งใจว่าโหลดไฟล์มาแล้วมีคำสั่งจัดการรวมหนี้ปกติและค้าง)
ไม่มีผลใดๆเกิดขึ้นครับยกเว้นคำสั่ง Sheet9.Range("T1").Value = "หนี้รวม"

With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=C:\Program Files\DumP\DATA\PALM.mdb;Mode=Share Deny Write" _
, _
";Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine " _
, _
"Type=5;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New " _
, _
"Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Comp" _
, "act=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("REGASSET")
.Name = "PALM"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\Program Files\DumP\DATA\PALM.mdb"
.Refresh BackgroundQuery:=True
Application.ScreenUpdating = True
End With
Tolone.Tolone (ไม่มีผลใดๆครับ)
MsgBox "โหลดข้อมูลสมบูรณ์", vbOKOnly, "DumP"
Sheets("master").Activate
If Err > 0 Then
Exit Sub
End If
End Sub

อาจารย์แนะนำหน่อยนะครับว่าจะแก้ไขอย่างไร (เวลาพิมพ์ข้อความมาเยอะๆก็เกรงครับกลัวจะเว้นบรรทัดไม่ถูก หากมีข้อแนะนำในหลักการเขียนกระทู้ เตือนผมด้วยนะครับ)

ปล.ที่สร้างเป็นโมดูลเพราะว่าคราวแรกผมเขียนคำสั่งตรงๆต่อท้ายไปเลย แต่ไม่ได้ผล ก็เลยเอาคำสั่งไปสร้างเป็นโมดูล แต่ก็ไม่ได้ผลเช่นกัน

[snasui]

ลองทดสอบด้วยคำสั่งอื่นเพื่อแสดงว่า Code ทำงานปกติตามลำดับหรือไม่ครับ

เช่นแทน Tolone.Tolone ด้วย

Code: Select all

MsgBox "Hello"

สังเกตว่าหลังจาก Run Code แล้ว คำว่า "Hello" แสดงหรือไม่ครับ

[Bafnet]

ลุ้นครับกลัวอาจารย์จะoffline
วางmsgBox ได้ผลครับ ขออนุญาติส่งคำสั่งทั้งคำสั่งนะครับ ซึ่งก็เป็นโมดูลที่ชื่อ Imdata แต่ชื่อ sub Re()

Sub Re()
Sheets("FileB").Activate
Columns("A:T").Select
Selection.ClearContents
Selection.QueryTable.Delete
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=C:\Program Files\DumP\DATA\PALM.mdb;Mode=Share Deny Write" _
, _
";Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine " _
, _
"Type=5;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New " _
, _
"Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Comp" _
, "act=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("FILEB")
.Name = "PALM"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\Program Files\DumP\DATA\PALM.mdb"
.Refresh BackgroundQuery:=True
Application.ScreenUpdating = True
End With
Sheets("FileC").Activate
Columns("A:E").Select
Selection.ClearContents
Selection.QueryTable.Delete
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=C:\Program Files\DumP\DATA\PALM.mdb;Mode=Share Deny Write" _
, _
";Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine " _
, _
"Type=5;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New " _
, _
"Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Comp" _
, "act=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("FILEC_DUE")
.Name = "PALM"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\Program Files\DumP\DATA\PALM.mdb"
.Refresh BackgroundQuery:=True
Application.ScreenUpdating = True
End With
Sheets("FileD").Activate
Columns("A:C").Select
Selection.ClearContents
Selection.QueryTable.Delete
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=C:\Program Files\DumP\DATA\PALM.mdb;Mode=Share Deny Write" _
, _
";Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine " _
, _
"Type=5;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New " _
, _
"Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Comp" _
, "act=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("FILED")
.Name = "PALM"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\Program Files\DumP\DATA\PALM.mdb"
.Refresh BackgroundQuery:=True
Application.ScreenUpdating = True
End With
Sheets("Perx").Activate
Columns("A:E").Select
Selection.ClearContents
Selection.QueryTable.Delete
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=C:\Program Files\DumP\DATA\PALM.mdb;Mode=Share Deny Write" _
, _
";Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine " _
, _
"Type=5;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New " _
, _
"Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Comp" _
, "act=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("PER1GARA")
.Name = "PALM"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\Program Files\DumP\DATA\PALM.mdb"
.Refresh BackgroundQuery:=True
Application.ScreenUpdating = True
End With
Sheets("Pergaran").Activate
Columns("A:F").Select
Selection.ClearContents
Selection.QueryTable.Delete
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=C:\Program Files\DumP\DATA\PALM.mdb;Mode=Share Deny Write" _
, _
";Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine " _
, _
"Type=5;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New " _
, _
"Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Comp" _
, "act=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("PERGARAN")
.Name = "PALM"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\Program Files\DumP\DATA\PALM.mdb"
.Refresh BackgroundQuery:=True
Application.ScreenUpdating = True
End With
Sheets("Regasset").Activate
Columns("A:I").Select
Selection.ClearContents
Selection.QueryTable.Delete
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=C:\Program Files\DumP\DATA\PALM.mdb;Mode=Share Deny Write" _
, _
";Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine " _
, _
"Type=5;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New " _
, _
"Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Comp" _
, "act=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("REGASSET")
.Name = "PALM"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\Program Files\DumP\DATA\PALM.mdb"
.Refresh BackgroundQuery:=True
Application.ScreenUpdating = True
End With
Tolone.Tolone
MsgBox "โหลดข้อมูลสมบูรณ์ì", vbOKOnly, "DumP"
Sheets("master").Activate
If Err > 0 Then
Exit Sub
End If
End Sub

โดยใช้คำสั่งนี้ที่ปุ่มคำสั่ง Loadlone

nm.jpg

อาจารครับหรือเพราะเราไปซ้อนโมดูลในคำสั่งที่เป็นโมดูล คำสั่งที่อยู่ใต้ Tolone.Tolone ทำงานครับ แต่คำสั่งที่อยู่ในTolone
ทำงานเฉพาะคำสั่ง
Sheet9.Activate
Sheet9.Range("T1").Value = "หนี้รวม"

[snasui]

...End With Tolone.Tolone MsgBox "โหลดข้อมูลสมบูรณ์ì", vbOKOnly, "DumP" Sheets("master").Activate...

จากด้านบนลองตามนี้ครับ

1. หากมี On Error Resume Next ให้ Mark เป็น Comment ไว้ก่อน
2. กด F8 1 ครั้ง
3. คลิกขวาที่ End With ก่อน Tolone.Tolone > Run to Cursor
4. กด F8 ซ้ำ ๆ เพื่อดูแต่ละ Step ว่า Code เกิด Error ตรงไหนหรือไม่ ถ้าไม่ Error ย่อมต้อง Run ครบทุกคำสั่งครับ

[Bafnet]

สวัสดีครับอาจารย์
ได้ทดสอบแล้วครับไม่ ERROR
แต่ก็ไม่ทำงานครับ และพอเพิ่มเครื่องมือเช่น Combobox ไปอีก 2 ตัวสั่งรัน
คราวนี้ Exel Err และปิดตัวเองครับ ต้องหาทางแก้อยู่ทั้งคืน จนไม่รู้จะทำอย่างไรเลยลองสร้าง USERFORM เพิ่ม
คือคิดว่า USERFORM เดิมรับคำสั่งมากตอนที่ Activate ตัวเอง ตอนนี้โปรแกรมที่สร้างก็รันได้ปกติแล้วครับ
แล้วนำ Tolone ไปสั่งในCommandButton ต่างหาก

อาจารย์ครับสอบถามต่อนะครับ มีคำสั่งดังนี้

Dim ry As Range
Dim ri As Range
Dim cri As Integer
If OptionButton4.Value = True And TextBox2.Value <> "" Then
Sheet15.Range("T53").Value = TextBox2.Value (กำหนดตำแหน่งค่าที่ผู้ใช้กรอกข้อมูล เช่น100000)
Sheet9.Activate
On Error Resume Next
With Workbooks("DumP.xlsm").Worksheets("FileB")
Set ri = .Range(.Range("A1"), .Range("T65536") _
.End(xlUp)).SpecialCells(xlCellTypeVisible)
cri = Sheet15.Range("T53").Value (กำหนดค่า Cri เป็นตัวเลข)
End With
With Workbooks("DumP.xlsm").Worksheets("Report")
Set ry = Workbooks("DumP.xlsm").Worksheets("Report").Range("A1")
End With
Sheet9.Activate
ActiveSheet.Range("A:T").AutoFilter Field:=14, Criteria1:="<>0", _ '(เงื่อนไขแรกกรองเฉพาะรายการคนที่มีหนี้ค้าง กรองสำเร็จ)
Operator:=xlAnd, Criteria2:="<=cri"
(เงื่อนไขที่สองกรองค่าที่น้อยกว่าหรือเท่ากับ cri ไม่ได้ผลครับ มันแสดงว่าไม่พบข้อมูล ผมรู้ว่าการเขียนนี้ผิดเพราะคิดว่ากลายเป็นสั่งให้หาค่าที่น้อยกว่าคำว่า cri
เพราะมี " " จะเขียนอย่างไรครับให้ได้ผลตามต้องการ)
ri.Select
ri.Copy: ry.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
TextBox1.Value = Sheet18.Range("Z2").Value
Sheet9.Activate
Sheet9.ShowAllData
End If

ผมต้องการกรองข้อมูลเฉพาะคนที่มีหนี้ค้าง ตามจำนวนที่น้อยกว่าค่าที่ผู้ใช้กรอกผ่านTextBox2.ซึ่งกำหนดค่าที่ Sheet15.Range("T53")
แต่การกำนดค่า cri ไม่ได้ผล เพราะคำสั่งดังกล่าวผมลอกมาจากการทดลองบันทึกมาโคร และพอจะทราบว่ากลายเป็นเรากำลังสั่งให้มันหาค่าที่น้อยกว่าคำว่า cri
รบกวนด้วยนะครับ

[snasui]

ได้ทดสอบเปลี่ยนค่าเป็นตามด้านล่างแล้วยังครับ

Operator:=xlAnd, Criteria2:="<=" & cri

[Bafnet]

ได้แล้วครับ คราวแรกผมก็เคยทำตามที่อาจารย์แนะนำมา แต่ก็ไม่ได้ผล
หลังจากอาจารย์แนะนำมาก็ยังไม่ได้ผล ก็นั่งพยายามอยู่
นึกขึ้นได้ว่าอาจารย์เคยสอนไว้ว่า ถ้าอยากรู้ว่ามันErr เพราะอะไรก็ให้ mark ' On ERRor resume next
ก็เห็นล่ะครับมัน Err ที่เรากำหนดค่า cri พอเอาเมาส์ไปชี้มันก็บอกว่า cri ="50000"
ก็ถึงบางอ้อครับ เลยไปลองแก้การประกาศตัวแปรซะใหม่
จากเดิม
Dim ry As Range
Dim ri As Range
Dim cri As Integer
เป็น
Dim ry As Range
Dim ri As Range
Dim cri As string
ได้ผลเลยครับและกำหนดให้ cri = TextBox2.Value โดยตรงไปเลย (ไม่เข้าใจว่าทำไมตอนแรกต้องโยงไปโยงมา )
เหนื่อยครับ...เราก็คิดว่าผู้ใช้คีย์ตัวเลข ในตารางข้อมูลก็เป็นตัวเลข ก็เลย Dim cri As Integer
ขอบคุณมากๆครับ
เดี๋ยวมาใหม่ครับ

[Bafnet]

สวัสดีครับ
มาอีกแล้วครับ
อาจารย์ครับช่วยให้ตัวอย่างที่จะให้ค่าที่ Sheets("FileB").Range("O")
มีสูตร VLOOKUP(C2,FileA!A:G,5,0)
C2 ต้องเปลี่ยนเป็น C3,C4 ไปเรื่อยๆ
ในคำสั่ง Loop ที่ส่งมาให้ครับ

[Bafnet]

ลืมไฟล์แนบครับ

สมุดงาน1.xlsm

[snasui]

สามารถปรับ Code เป็นตามด้านล่างครับ

Code: Select all

Sheet2.Cells(r, 15).Formula = "=VLOOKUP(" & Sheet2.Cells(r, 3) & ",FileA!A:G,5,0)"

[Bafnet]

สวัสดีครับ..มาอีกแล้วปัญหาๆๆ
ที่อาจารย์ปรับcode มาให้ใช้ได้ดีครับ แต่ยังไม่สำเร็จผมนำ code ไปปรับและเพิ่มเติมดังนี้

Sub Tolone
Dim r As Integer
Dim i As Single
Dim y As Single
With Workbooks("DumP.xlsm").Worksheets("FileB")
Sheet9.Range("T1").Value = "˹ÕéÃÇÁ"
r = 2
Do Until Sheet9.Cells(r, 1).Value = ""
i = Sheet9.Cells(r, 12).Value
y = Sheet9.Cells(r, 14).Value
Sheet9.Cells(r, 20).Value = i + y
Sheet9.Cells(r, 15).Formula = "=VLOOKUP(" & Sheet9.Cells(r, 3) & ",FileA!A:G,5,0)"
Sheet9.Cells(r, 16).Formula = "=VLOOKUP(" & Sheet9.Cells(r, 3) & ",FileA!A:G,7,0)"
r = r + 1
Loop
End With

With Workbooks("DumP.xlsm").Worksheets("FileC")
Sheet10.Range("F1").Value = "เลขทะเบียน"
Sheet10.Range("G1").Value = "ชื่อสกุล"
Sheet10.Range("H1").Value = "ที่อยู่"
Sheet10.Range("I1").Value = "รหัสโครงการ"
r = 2
Do Until Sheet10.Cells(r, 1).Value = ""
Sheet10.Cells(r, 6).Formula = "=VLOOKUP(" & Sheet10.Cells(r, 1) & "),FileB!A:T,3,0)"
'Sheet10.Cells(r, 7).Formula = "=VLOOKUP(" & Sheet10.Cells(r, 1) & ",FileB!A:T,15,0)"
'Sheet10.Cells(r, 8).Formula = "=VLOOKUP(" & Sheet10.Cells(r, 1) & ",FileB!A:T,16,0)"
'Sheet10.Cells(r, 9).Formula = "=VLOOKUP(" & Sheet10.Cells(r, 1) & ",FileB!A:T,17,0)"
r = r + 1
Loop
End With
กะว่าได้แล้วเชียว แต่ไม่ได้ครับผมคิดว่าเพราะที่ตำแหน่ง(ชีท FileB) Sheet10.Cells(r, 1) ตัวเลขดังกล่าวอยู่ในลักษณะข้อความ
เมื่อไปดูสูตรที่สร้างขึ้นพบว่า สูตรเขียนเป็น =VLOOKUP(40014235,FileB!A:T,3,0) ที่เราต้องการคือ =VLOOKUP(A2,FileB!A:T,3,0)
พยายามทั้งลบทั้งเติม ก็ยังไม่ได้ครับ
ไฟล์ตัวอย่างคือสมุดงาน1.xlsm
ขอบคุณครับ