ค้นหาข้อมูลจากอีก Sheet

[wisitsakbenz]

เรียน อาจารย์

1. ต้องการค้นหาข้อมูลจากอีก Sheet แล้วมาแสดง
ถ้าอยากให้ค้นหาโดยที่ไม่ต้องเปิดไฟล์ที่ต้องการค้นหา จะต้องปรับ Code อย่างไรครับ หรืออาจารย์พอมีวิธีอื่นหรือไม่ครับ
(Data ประมาณ 20กว่า M ครับ)

ไฟล์ : Pre-Arrangement1 - Copy อยู่ในเครื่อง
ไฟล์ : All Data Estimated อยู่ที่ Server ครับ

Code: Select all

Private Sub CommandButton2_Click()
Dim sb As Workbook
Dim sh As Worksheet
Dim rngA As Range
Dim r As Range
Dim strSb As String
Dim Ref As String
Dim f As Boolean
strSb = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
Set sb = Workbooks.Open(Filename:=strSb, UpdateLinks:=False, ReadOnly:=True)
f = False
With ThisWorkbook.Worksheets("Input")
    Ref = .Range("F6").Value
    For Each sh In sb.Worksheets
        Set rngA = sh.Range("a2", sh.Range("a" & sh.Rows.Count).End(xlUp))
        For Each r In rngA
            If r.Value = Ref Then
                .Range("C10").Value = r.Offset(0, 6).Value
                .Range("F10").Value = r.Offset(0, 5).Value
                .Range("C12").Value = r.Offset(0, 7).Value
                .Range("C14").Value = r.Offset(0, 12).Value
                 .Range("C16").Value = r.Offset(0, 11).Value
                 .Range("C18").Value = r.Offset(0, 16).Value
                .Range("C20").Value = r.Offset(0, 20).Value
                .Range("C22").Value = r.Offset(0, 22).Value
                .Range("E22").Value = r.Offset(0, 23).Value
                f = True
                Exit For
            End If
        Next r
        If f Then Exit For
    Next sh
End With
sb.Close False
End Sub

2.ต้องการ Search HN โดยค้นหาที่เดียวกันกับข้อ 1 ให้มาแสดงใน ListBox ยัง error อยู่
จะต้องปรับ Code อย่างไรครับ

Code: Select all

 
Private Sub CommandButton1_Click()

Dim sb As Workbook
Dim sh As Worksheet
Dim rngA As Range
Dim r As Range
Dim strSb As String
Dim Ref As String
Dim f As Boolean
strSb = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
Set sb = Workbooks.Open(Filename:=strSb, UpdateLinks:=False, ReadOnly:=False)
f = False

'Other code
Dim i As Long, j As Long
Dim arr(0, 26) As Variant
Me.ListBox1.Clear
Me.ListBox1.AddItem
For a = 0 To 26
    arr(0, a) = sh.Cells(1, a + 1).Value
'    Me.ListBox1.List(0, a - 1) = Sheet1.Cells(1, a)
Next a
Me.ListBox1.ColumnCount = 26
Me.ListBox1.List = arr
'Me.ListBox1.Locked = True
ListBox1.ColumnWidths = "25 ,0 ,0 ,0,0 ,64 ,0 ,68 ,60,25, 25,70 ,70 ,0 ,0 ,0 ,0,80,0 ,0 ,0 ,0 ,0 ,0 ,0, 50"
ListBox1.Height = 170
ListBox1.Width = 550
ListBox1.Left = 764
ListBox1.Top = 282
'Other code
    'For List Box fill
    'For i = 2 To Sheet4.Range("A1000000").End(xlUp).Row
   
     For i = sh.Range("A1000000").End(xlUp).Row To 2 Step -1
        If sb.Cells(i, 7).Value = TextBox1.Value Then
            Me.ListBox1.AddItem
            For x = 1 To 26
                Me.ListBox1.List(ListBox1.ListCount - 1, x - 1) = sh.Cells(i, x)
            Next x
        End If
    Next i

ขอบคุณครับ

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Private Sub CommandButton1_Click()

    Dim sb As Workbook
    Dim sh As Worksheet
    Dim rngA As Range
    Dim r As Range
    Dim strSb As String
    Dim Ref As String
    Dim f As Boolean
    strSb = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    Set sb = Workbooks.Open(Filename:=strSb, UpdateLinks:=False, ReadOnly:=False)
    Set sh = sb.Worksheets("Data")
    f = False
    
    'Other code
    Dim i As Long, j As Long
    Dim b As Variant
    Dim arr(0, 26) As Variant
    Me.ListBox1.Clear
    Me.ListBox1.AddItem
    
    ReDim b(sh.Range("A1000000").End(xlUp).Row, 26)
    'For i = sh.Range("A1000000").End(xlUp).Row To 2 Step -1
    For i = 0 To UBound(b)
        For a = 0 To 26
            b(i, a) = sh.Cells(i + 2, a + 1).Value
            Debug.Print sh.Cells(i + 2, a + 1).Address
        '    Me.ListBox1.List(0, a - 1) = Sheet1.Cells(1, a)
        Next a
    Next i
    Me.ListBox1.ColumnCount = 26
    Me.ListBox1.List = b
    'Me.ListBox1.Locked = True
    ListBox1.ColumnWidths = "25 ,0 ,0 ,0,0 ,64 ,0 ,68 ,60,25, 25,70 ,70 ,0 ,0 ,0 ,0,80,0 ,0 ,0 ,0 ,0 ,0 ,0, 50"
    ListBox1.Height = 170
    ListBox1.Width = 550
    ListBox1.Left = 764
    ListBox1.Top = 282
    'Other code
        'For List Box fill
        'For i = 2 To Sheet4.Range("A1000000").End(xlUp).Row
       
    '        If sb.Cells(i, 7).Value = TextBox1.Value Then
    '            Me.ListBox1.AddItem
    '            For x = 1 To 26
    '                Me.ListBox1.List(ListBox1.ListCount - 1, x - 1) = sh.Cells(i, x)
    '            Next x
    '        End If

End Sub

กรณีต้องการนำข้อมูลจากไฟล์ที่ปิดอยูมาใช้งานลองดูตัวอย่าง Code จากโพสต์นี้ครับ viewtopic.php?t=19553#p113919

ลองดัดแปลงแก้ไขให้เข้ากับงานของตัวเอง ติดตรงไหนค่อยนำมาถามกันต่อครับ

[wisitsakbenz]

เรียน อาจารย์

ทางผมลองทำดูแล้ว แต่ยังติดปัญหาอยู่ ไม่ค่อยเข้าใจ Code เท่าไหร่ แต่พยายามปรับเปลี่ยน หรือศึกษาแล้ว
ข้อมูลที่ต้องการไม่แสดงใน Lixtbox
ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

Sub sample2()

    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "\\10.21.4.97\File Sharing2\DataPricing\"
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder2 FileSystem.GetFolder(HostFolder)
    
End Sub


Sub DoFolder2(Folder)
    Dim SubFolder
    Dim File
    Dim n As Long
    Dim n2 As Long
    Dim sh As Worksheet
    Dim tws As Workbook
    
    Dim i As Long, j As Long
    Dim b As Variant
    Dim arr(0, 26) As Variant
      
    For Each File In Folder.Files
        If File.Name = "All Data Estimated" Then
    ListBox1.Clear
   ListBox1.AddItem
    
    ReDim b(sh.Range("A1000000").End(xlUp).Row, 26)
    For i = 0 To UBound(b)
        For a = 0 To 26
            b(i, a) = sh.Cells(i + 2, a + 1).Value
            Debug.Print sh.Cells(i + 2, a + 1).Address
        Next a
    Next i
    
            Call GetSheetname(theFullName:=File)
        End If
    Next
End Sub

Sub ImportFile(sFile As String, sh As String)
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    On Error Resume Next
    shtName = "[" & VBA.Replace(sh, "'", "") & "]"
    sql = "select * from " & shtName
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("data")
        .Range("A" & Rows.Count).End(xlUp).Offset(1, 0) _
            .CopyFromRecordset rs
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub


Function GetSheetname(ByVal theFullName As String) As String
    Dim cn As ADODB.Connection
    Dim rsT As ADODB.Recordset
    Dim intTblCnt As Integer
    Dim strTbl As String
    Dim t As Integer
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
      '  & "Data Source=" & theFullName & ";" _
      '  & "Extended Properties=""Excel 12.0 Xml;HDR=NO"";"

    Set rsT = cn.OpenSchema(adSchemaTables)
    intTblCnt = rsT.RecordCount

    Do While Not rsT.EOF
        strTbl = rsT.Fields("TABLE_NAME").Value
        If Right(strTbl, 2) = "$'" And VBA.Left(strTbl, 11) = "'COST SHEET" Then
           Call ImportFile(sFile:=theFullName, sh:=strTbl)
        End If
        rsT.MoveNext
    Loop
    rsT.Close
    cn.Close
End Function

[snasui]

ตัวอย่าง Code สำหรับการดึงข้อมูลจากไฟล์ต้นทางที่ปิดอยู่เพื่อนำค่ามาใส่ ListBox ลองปรับใช้ดูครับ

Code: Select all

Sub ImportData()
    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "select * from " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("input")
        .ListBox1.Clear
        .ListBox1.AddItem
        ReDim arr(rs.RecordCount, 26)
        Do While Not rs.EOF
            For i = 0 To 26
                arr(j, i) = rs.Fields(i).Value
            Next i
            j = j + 1
            rs.MoveNext
        Loop
        .ListBox1.List = arr
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

[wisitsakbenz]

เรียน อาจารย์ Snasui

ขอโทษอาจารย์ที่ตอบช้าครับ
1.อยากให้ข้อมูลใน Listbox เรียงจาก Ref มากไปน้อย ต้องปรับ Code อย่างไรครับ
2.ในกรณีที่ Save ข้อมูลในที่เดียวกันโดยไม่เปิดไฟล์ ผมได้ลองเขียน Code แล้ว แต่ยังติดปัญหาอยู่
ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

Sub SaveData()

ColName = 6
 ColHN = 7
ColDOB = 8
ColPayer = 9
ColNation = 10

    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    Dim WI As Worksheet
    
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "select * from " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    
    Set WI = Worksheets("Input")
    Set WD = rs.Worksheets("Data")
    
    'Find the next empty row
    Dim lastrow As Long
    Dim NewRow As Long
    Dim LastRowDate As Long
    Dim NewRowDate As Long
    
    lastrow = WD.Range("A1000000").End(xlUp).Row
    NewRow = lastrow + 1
    
'Create reference number
    WD.Cells(NewRow, 2).Value = Day(Date)
    WD.Cells(NewRow, 3).Value = Month(Date)
    WD.Cells(NewRow, 4).Value = Year(Date) - 2000
    
    
    'Reference number reset to 1 on new date
    LastRowDate = WD.Cells(lastrow, 2).Value
    NewRowDate = WD.Cells(NewRow, 2).Value
    If LastRowDate <> NewRowDate Then
        WD.Cells(NewRow, 5).Value = 1
    Else
        WD.Cells(NewRow, 5).Value = WD.Cells(lastrow, 5) + 1
    End If
    
  
    'Format month, date, and reference number
    WD.Cells(NewRow, 3).NumberFormat = "00"
    WD.Cells(NewRow, 2).NumberFormat = "00"
    WD.Cells(NewRow, 5).NumberFormat = "0000"

    'Assign unique reference number in column 1
    RefNo = WD.Cells(NewRow, 4).Text & "-" & WD.Cells(NewRow, 3).Text & "-" & WD.Cells(NewRow, 2).Text & "-" & WD.Cells(NewRow, 5).Text
    WD.Cells(NewRow, 1).Value = RefNo
    
    
    'Assign RefNo back to Input page
    WI.Range("InputRefNo") = RefNo
    
    'Assign Date/Time
    WI.Range("InputEstimateDateTime") = Now
    
         WD.Cells(NewRow, ColName).Value = WI.Range("InputName")
    WD.Cells(NewRow, ColHN).Value = WI.Range("InputHN")
    WD.Cells(NewRow, ColDOB).Value = WI.Range("InputDOB")
    WD.Cells(NewRow, ColPayer).Value = WI.Range("InputPayer")
    WD.Cells(NewRow, ColNation).Value = WI.Range("InputNation")
    
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

[wisitsakbenz]

เรียน อาจารย์ Snasui

ติดปัญหาอีกอย่างคือ คลิก Search HN ข้อมูลจะแสดงทั้งหมด ไม่ได้แสดง HN ที่ค้นหา
ต้องปรับสูตรอย่างไรครับ

Code: Select all

Sub ImportData()
    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "select * from " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("input")
     If rs.Cells(i, 7).Value = Sheet1.Cells(3, 15).Value Then
        .ListBox1.Clear
        .ListBox1.AddItem
        ReDim arr(rs.RecordCount, 26)
        Do While Not rs.EOF
            For i = 0 To 26
                arr(j, i) = rs.Fields(i).Value
            Next i
            j = j + 1
            rs.MoveNext
        Loop
        .ListBox1.List = arr
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

[snasui]

คลิก Search HN ข้อมูลจะแสดงทั้งหมด ไม่ได้แสดง HN ที่ค้นหา

เขียน Code ไว้ตรงไหนในเรื่องการ Search กรุณาแจ้งมาด้วยจะได้เข้าถึงปัญหาโดยไว ถ้ายังไม่เขียนกรุณาเขียนมาก่อนครับ

[wisitsakbenz]

เรียน อาจารย์ Snasui

ผมได้ปรับในส่วนนี้ แต่ยังติดอยู่ครับ
ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

'--------other code------------
    With Worksheets("input")
     If rs.Fields(7).Value = Sheet1.Cells(3, 15).Value Then
        .ListBox1.Clear
        .ListBox1.AddItem
        ReDim arr(rs.RecordCount, 26)
        Do While Not rs.EOF
            For i = 0 To 26
                arr(j, i) = rs.Fields(i).Value
            Next i
            j = j + 1
            rs.MoveNext
        Loop
        .ListBox1.List = arr
          End If
    End With

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub ImportData()
    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    Dim strS As String
    
    strS = Sheets(1).OLEObjects("TextBox1").Object.Text
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "select * from " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("input")
'     If rs.Fields(7).Value = Sheet1.Cells(3, 15).Value Then
        .ListBox1.Clear
        .ListBox1.AddItem
        ReDim arr(rs.RecordCount, 26)
        Do While Not rs.EOF
            If rs.Fields(6).Value = "HN" Or rs.Fields(6).Value = strS Then
                For i = 0 To 26
                    arr(j, i) = rs.Fields(i).Value
                Next i
            End If
            j = j + 1
            rs.MoveNext
        Loop
        .ListBox1.List = arr
'          End If
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

[wisitsakbenz]

เรียน อาจารย์

หลังจากค้นหาแล้ว ผลลัพธ์ที่ได้จะเว้นบรรทัด
ถ้าไม่อยากให้มีการเว้นบรรทัด และอยากให้ผลลัพธ์แสดง Ref มากไปยังน้อย
ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

           If rs.Fields(6).Value = "HN" Or rs.Fields(6).Value = strS Then
                For i = 0 To 26
                    arr(j, i) = rs.Fields(i).Value
                    
                  If arr(j, i) = "" Then
                  arr(j, i).EntireRow.Delete
                  End If
                  
                Next i
            End If
            j = j + 1
            rs.MoveNext

[snasui]

หลังจากค้นหาแล้ว ผลลัพธ์ที่ได้จะเว้นบรรทัด

นำ j = j + 1 ไปไว้บรรทัดล่างของ Next i ครับ

อยากให้ผลลัพธ์แสดง Ref มากไปยังน้อย
ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

คอลัมน์ไหนคือ Ref ครับ

[wisitsakbenz]

เรียน อาจารย์ snasui

เช่นค้นหา HN : 11-18-048
อยากให้แสดงข้อมูล 21-01-01-003 ก่อน หรือข้อมูลล่าสุดของ HN นั้นๆ ก่อนครับ
ขอบคุณครับ

[snasui]

คำว่าล่าสุดอยู่ท้ายสุดใช่หรือไม่ครับหรือเรียงแบบไหน กรุณาให้รายละเอียดที่สามารถเข้าใจได้ด้วยครับ

กรณีต้องการเรียงจากน้อยไปหามากหรือมากไปหาน้อยสามารถเรียงจากต้นทาง หากเรียงใน ListBox จะค่อนข้างวุ้นวายพอสมควร ปกติสามารถเรียงด้วย Statement ของ SQL ได้ แต่กรณีนี้ไม่ง่ายที่จะใช้ SQL Statement ในการเรียง ยกเว้น Database คือ SQL เช่นนี้เป็นต้นครับ

ตัวอย่างการ Sort ใน ListBox https://stackoverflow.com/questions/623 ... ding-order

https://exceloffthegrid.com/sorting-listboxes-with-vba/

นอกจากนี้ยังสามารถนำข้อมูลมาวางในชีตใด ๆ แล้วค่อย Sort แล้วเก็บค่าหลัง Sort แล้วเข้าไปใน ListBox ซึ่งจะง่ายกว่าวิธีข้างบนครับ

[wisitsakbenz]

เรียน อาจารย์

-การเรียงข้อมูลจะลองทำตามอาจารย์แนะนำก่อนครับ และยังติดอีกปัญหาที่เคยโพสไปแล้วคือ
กรณีที่ Save ข้อมูลในที่เดียวกันโดยไม่เปิดไฟล์ ผมได้ลองเขียน Code แล้ว แต่ยังติดปัญหาอยู่
ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

Sub SaveData()

ColName = 6
 ColHN = 7
ColDOB = 8
ColPayer = 9
ColNation = 10

    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    Dim WI As Worksheet
    
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "select * from " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    
    Set WI = Worksheets("Input")
    Set WD = rs.Worksheets("Data")
    
    'Find the next empty row
    Dim lastrow As Long
    Dim NewRow As Long
    Dim LastRowDate As Long
    Dim NewRowDate As Long
    
    lastrow = WD.Range("A1000000").End(xlUp).Row
    NewRow = lastrow + 1
    
'Create reference number
    WD.Cells(NewRow, 2).Value = Day(Date)
    WD.Cells(NewRow, 3).Value = Month(Date)
    WD.Cells(NewRow, 4).Value = Year(Date) - 2000
    
    
    'Reference number reset to 1 on new date
    LastRowDate = WD.Cells(lastrow, 2).Value
    NewRowDate = WD.Cells(NewRow, 2).Value
    If LastRowDate <> NewRowDate Then
        WD.Cells(NewRow, 5).Value = 1
    Else
        WD.Cells(NewRow, 5).Value = WD.Cells(lastrow, 5) + 1
    End If
    
  
    'Format month, date, and reference number
    WD.Cells(NewRow, 3).NumberFormat = "00"
    WD.Cells(NewRow, 2).NumberFormat = "00"
    WD.Cells(NewRow, 5).NumberFormat = "0000"

    'Assign unique reference number in column 1
    RefNo = WD.Cells(NewRow, 4).Text & "-" & WD.Cells(NewRow, 3).Text & "-" & WD.Cells(NewRow, 2).Text & "-" & WD.Cells(NewRow, 5).Text
    WD.Cells(NewRow, 1).Value = RefNo
    
    
    'Assign RefNo back to Input page
    WI.Range("InputRefNo") = RefNo
    
    'Assign Date/Time
    WI.Range("InputEstimateDateTime") = Now
    
         WD.Cells(NewRow, ColName).Value = WI.Range("InputName")
    WD.Cells(NewRow, ColHN).Value = WI.Range("InputHN")
    WD.Cells(NewRow, ColDOB).Value = WI.Range("InputDOB")
    WD.Cells(NewRow, ColPayer).Value = WI.Range("InputPayer")
    WD.Cells(NewRow, ColNation).Value = WI.Range("InputNation")
    
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

[snasui]

ช่วยอธิบายว่า Save ข้อมูลไปที่เดียวโดยไม่เปิดไฟล์เป็นการ Save ไปที่ไหน ช่วยลำดับขั้นตอนการทำงานมาด้วย

Code ที่เขียนมานั้นเป็นการดึงข้อมูลมาแสดงไม่ใช่ Save กลับไป กรณีใช้ Statement SQL จะต้องมีคำว่า Update เพื่อ Update ข้อมูลเดิมหรือมีคำว่า Insert หากเป็นข้อมูลใหม่ ไม่ใช่เป็นคำว่า Select อยู่เช่นเดิมซึ่งหมายถึงการนำมาใช้งาน

ช่วยปรับ Code ให้เป็นการ Save อย่างที่กล่าวมาด้วยครับ

[wisitsakbenz]

เรียน อาจารย์ snasui

ขอโทษอาจารย์ด้วยครับ
กรอกข้อมูลแล้ว คลิกปุ่ม Save ข้อมูลจะถูกบันทึกใน workbook > "All Data Estimated" , worksheet > "Data"
ซึ่งอยู่ที่ Path : \\10.21.4.97\File Sharing2\DataPricing
ขอบคุณครับ

Code: Select all

Sub SaveData()

ColName = 6
 ColHN = 7
ColDOB = 8
ColPayer = 9
ColNation = 10

    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    Dim WI As Worksheet
    
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "insert into " & shtName
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    
    Set WI = Worksheets("Input")
    Set WD = rs.Worksheets("Data")
    
    'Find the next empty row
    Dim lastrow As Long
    Dim NewRow As Long
    Dim LastRowDate As Long
    Dim NewRowDate As Long
    
    lastrow = WD.Range("A1000000").End(xlUp).Row
    NewRow = lastrow + 1
    
'Create reference number
    WD.Cells(NewRow, 2).Value = Day(Date)
    WD.Cells(NewRow, 3).Value = Month(Date)
    WD.Cells(NewRow, 4).Value = Year(Date) - 2000
    
    
    'Reference number reset to 1 on new date
    LastRowDate = WD.Cells(lastrow, 2).Value
    NewRowDate = WD.Cells(NewRow, 2).Value
    If LastRowDate <> NewRowDate Then
        WD.Cells(NewRow, 5).Value = 1
    Else
        WD.Cells(NewRow, 5).Value = WD.Cells(lastrow, 5) + 1
    End If
    
  
    'Format month, date, and reference number
    WD.Cells(NewRow, 3).NumberFormat = "00"
    WD.Cells(NewRow, 2).NumberFormat = "00"
    WD.Cells(NewRow, 5).NumberFormat = "0000"

    'Assign unique reference number in column 1
    RefNo = WD.Cells(NewRow, 4).Text & "-" & WD.Cells(NewRow, 3).Text & "-" & WD.Cells(NewRow, 2).Text & "-" & WD.Cells(NewRow, 5).Text
    WD.Cells(NewRow, 1).Value = RefNo
    
    
    'Assign RefNo back to Input page
    WI.Range("InputRefNo") = RefNo
    
    'Assign Date/Time
    WI.Range("InputEstimateDateTime") = Now
    
         WD.Cells(NewRow, ColName).Value = WI.Range("InputName")
    WD.Cells(NewRow, ColHN).Value = WI.Range("InputHN")
    WD.Cells(NewRow, ColDOB).Value = WI.Range("InputDOB")
    WD.Cells(NewRow, ColPayer).Value = WI.Range("InputPayer")
    WD.Cells(NewRow, ColUsePackage).Value = WI.Range("InputUsePackage")
    WD.Cells(NewRow, ColNation).Value = WI.Range("InputNation")


    
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

[snasui]

ผมสังเกตไฟล์ All Data Estimated.xlsx บรรทัดแรกไม่ใช่หัวคอลัมน์ ให้ลบบรรทัดนั้นทิ้งไปเพราะมันจะไม่เป็น Database ทำให้เขียน SQL ยุ่งยากขึ้นกว่าเดิม เช่นต้องเพิ่ม Range ตามเข้ามาด้วย เช่นนี้เป็นต้น

จากนั้นใช้ Code ด้านล่างสำหรับการดึงข้อมูลตามเงื่อนไขและมีการเรียงให้แล้วตาม SQL Statement ใน Code ด้านล่าง

Code: Select all

Sub ImportData()
    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer, k As Integer
    Dim strS As String
    
    strS = Sheets(1).OLEObjects("TextBox1").Object.Text
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"

    shtName = "[Data$]"
    sql = "select * from " & shtName & " Where HN ='" & strS & " ' Order By 'RefNo'"
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("input")
        .ListBox1.Clear
        .ListBox1.AddItem
        ReDim arr(rs.RecordCount, 26)
        Do While Not rs.EOF
            For i = 0 To 26
                If j = 0 Then
                    For k = 0 To 26
                        arr(j, k) = rs.Fields(k).Name
                    Next k
                    j = j + 1
                End If
                arr(j, i) = rs.Fields(i).Value
            Next i
            j = j + 1
            rs.MoveNext
        Loop
        .ListBox1.List = arr
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

ในการบ้นทึกกลับไปจะต้องตัดสินใจว่าบันทึกเพิ่มเข้าไปหรือว่าเป็นการ Update รายการเดิม มันต้องมี Where Clause ด้วยครับ นอกจากนี้หากบันทึกครั้งละหลายรายการจะต้อง Loop เข้าไปทีละรายการใส่เข้าที่ Statement Insert หรือ Update ครับ

[wisitsakbenz]

เรียน อาจารย์ snasui

ตอบคำถามอาจารย์ครับ

ผมสังเกตไฟล์ All Data Estimated.xlsx บรรทัดแรกไม่ใช่หัวคอลัมน์ ให้ลบบรรทัดนั้นทิ้งไปเพราะมันจะไม่เป็น Database ทำให้เขียน SQL ยุ่งยากขึ้นกว่าเดิม เช่นต้องเพิ่ม Range ตามเข้ามาด้วย

ในการบ้นทึกกลับไปจะต้องตัดสินใจว่าบันทึกเพิ่มเข้าไปหรือว่าเป็นการ Update รายการเดิม มันต้องมี Where Clause ด้วยครับ นอกจากนี้หากบันทึกครั้งละหลายรายการจะต้อง Loop เข้าไปทีละรายการใส่เข้าที่ Statement Insert หรือ Update ครับ

-ลบบรรทัดแรกแล้ว ได้ผลตามต้องการแล้วครับ
-คลิก Save คือการบันทึกข้อมูลเข้าไปใน All Data Estimated.xlsx > sheet "Data" อย่างเดียว ไม่มีการ update ครับ

อยากสอบถามอาจารย์เพิ่มเติมครับ
กรอกข้อมูลที่ >Workbook "Pre-Arrangement1-Copy" sheet "input"

ช่อง F6 จะไม่ใส่ค่า ระบบจะ Generate ให้อัตโนมัติหลังจากที่คลิกปุ่ม Save
โดยกำหนด = ปี-เดือน-วัน-Running Number
โดยที่ปี = ปีปัจุบัน - 2000
เช่นปี 2022 เดือน พฤศจิกายน วันที่ 20
เลข Refno ที่ได้ = 22-11-20-0001

ช่อง C20 จะไม่ใส่ค่า ระบบจะ Generate ให้อัตโนมัติหลังจากที่คลิกปุ่ม Save จะเท่ากับ วันที่และเวลาขณะ Save format = "dd/mm/yy hh:mm"

เมื่อกรอกรายละเอียดครบแล้ว คลิกปุ่ม Save ข้อมูลจะถูกบันทึกใน \\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx
ทางผมลองเขียน Code แล้วแต่ยังติดปัญหาอยู่ ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

Sub SaveData()

ColName = 6
 ColHN = 7
ColDOB = 8
ColPayer = 9
ColNation = 10

    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    Dim WI As Worksheet
    
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    sql = "insert  into  " & sFile
    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    
    Set WI = Worksheets("Input")
    Set OW = Workbooks("All Data Estimated.xlsx")
    Set WD = OW.Worksheets("Data")
    
    'Find the next empty row
    Dim lastrow As Long
    Dim NewRow As Long
    Dim LastRowDate As Long
    Dim NewRowDate As Long
    
    lastrow = WD.Range("A1000000").End(xlUp).Row
    NewRow = lastrow + 1
    
'Create reference number
    WD.Cells(NewRow, 2).Value = Day(Date)
    WD.Cells(NewRow, 3).Value = Month(Date)
    WD.Cells(NewRow, 4).Value = Year(Date) - 2000
    
    
    'Reference number reset to 1 on new date
    LastRowDate = WD.Cells(lastrow, 2).Value
    NewRowDate = WD.Cells(NewRow, 2).Value
    If LastRowDate <> NewRowDate Then
        WD.Cells(NewRow, 5).Value = 1
    Else
        WD.Cells(NewRow, 5).Value = WD.Cells(lastrow, 5) + 1
    End If
    
  
    'Format month, date, and reference number
    WD.Cells(NewRow, 3).NumberFormat = "00"
    WD.Cells(NewRow, 2).NumberFormat = "00"
    WD.Cells(NewRow, 5).NumberFormat = "0000"

    'Assign unique reference number in column 1
    Refno = WD.Cells(NewRow, 4).Text & "-" & WD.Cells(NewRow, 3).Text & "-" & WD.Cells(NewRow, 2).Text & "-" & WD.Cells(NewRow, 5).Text
    WD.Cells(NewRow, 1).Value = Refno
    
    
    'Assign RefNo back to Input page
    WI.Range("InputRefNo") = Refno
    
    'Assign Date/Time
    WI.Range("InputEstimateDateTime") = Now
    
         WD.Cells(NewRow, ColName).Value = WI.Range("InputName")
    WD.Cells(NewRow, ColHN).Value = WI.Range("InputHN")
    WD.Cells(NewRow, ColDOB).Value = WI.Range("InputDOB")
    WD.Cells(NewRow, ColPayer).Value = WI.Range("InputPayer")
    WD.Cells(NewRow, ColUsePackage).Value = WI.Range("InputUsePackage")
    WD.Cells(NewRow, ColNation).Value = WI.Range("InputNation")
    
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

[snasui]

Code ที่เขียนมาไม่ใช่ Code สำหรับการ Insert ข้อมูลเข้าไปในไฟล์ที่ปิด จะต้องศึกษาเกี่ยวกับการใช้ SQL Statement สำหรับการนำข้อมูลเข้าไปวางใน Database ให้เข้าใจเสียก่อน

วิธีการนำข้อมูลที่ไม่เป็นระเบียบเข้าไปวางในไฟล์ที่ปิดด้วย SQL Statement สามารถทำให้ง่ายลงด้วยการ Link ข้อมูลเหล่านั้นไปเรียงให้เป็น Record คล้ายกับข้อมูลปลายทาง โดยมีหัวคอลัมน์กำกับให้เรียบร้อย จากนั้นค่อยนำไปวางในไฟล์ปลายทางด้วย SQL Statement เช่น

Code: Select all

strSql = "INSERT INTO [Sheet1$]" & _
            " SELECT * FROM [Excel 12.0 Macro;HDR=Yes;" & _
            " Database=" & thisworkbook.fullname & ";Readonly=False].[Sheet1$I1:N4]"

จาก Sheet1$I1:N4 ใน Code หมายถึงพื้นที่จะวางข้อมูลไว้เป็นระเบียบพร้อมนำเข้าไปวางในไฟล์ปลายทางดังที่กล่าวไว้ข้างบนแล้ว เมื่อจะนำไปใช้งานจริงให้ปรับ Sheet1$ เป็นชื่อชีตที่ใช้จริง

ส่วน Code อื่นใดที่อยู่ด้านล่างบรรทัด rs.Open sql, sCnstr จากโพสต์ที่ 18 ไม่สามารถวางค่าในไฟล์ที่ปิดได้ด้วยวิธีการนี้ ลบทิ้งไปได้เลยยกเว้นด้านล่างครับ
Set sCnstr = Nothing
Set rs = Nothing

[wisitsakbenz]

เรียน อาจารย์ snasui

ทำตามคำที่อาจารย์แนะนำแล้ว ไม่แน่ใจว่าถูกหรือไม่
และอยากสอบถามค่าที่กรอกในแต่ละช่อง จะมีการเก็บอย่างไรครับ
ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

Sub SaveData()

    Dim sFile As String, sh As Worksheet
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    Dim arr() As Variant, i As Integer, j As Integer
    
    sFile = "\\10.21.4.97\File Sharing2\DataPricing\All Data Estimated.xlsx"
    shtName = "[Data$]"
    strSql = "INSERT INTO [Data$]" & _
            " SELECT * FROM [Excel 12.0 Macro;HDR=Yes;" & _
            " Database=" & ThisWorkbook.FullName & ";Readonly=False].[Sheet1$I1:N4]"

    sCnstr.CursorLocation = adUseClient
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub