EXCEL TOOLS
Excel Add-ins ที่พัฒนาโดยคุณสันติพงศ์ ณสุย (MVP Excel 2010-2020) ด้วยภาษา C# เพื่อแก้ไขปัญหาไฟล์ใหญ่ คำนวณนาน ทำงานช้า จัดการข้อมูลต่าง ๆ ที่ทำงานประจำวันได้อย่างสะดวกรวดเร็ว สนใจคลิกไปดูได้ที่นี่ครับ => Excel Tools
Excel Add-ins ที่พัฒนาโดยคุณสันติพงศ์ ณสุย (MVP Excel 2010-2020) ด้วยภาษา C# เพื่อแก้ไขปัญหาไฟล์ใหญ่ คำนวณนาน ทำงานช้า จัดการข้อมูลต่าง ๆ ที่ทำงานประจำวันได้อย่างสะดวกรวดเร็ว สนใจคลิกไปดูได้ที่นี่ครับ => Excel Tools
[code]
และปิดด้วย [/code]
ตัวอย่างเช่น [code]dim r as range[/code]
เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)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
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
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: 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
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
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
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
เขียน Code ไว้ตรงไหนในเรื่องการ Search กรุณาแจ้งมาด้วยจะได้เข้าถึงปัญหาโดยไว ถ้ายังไม่เขียนกรุณาเขียนมาก่อนครับwisitsakbenz wrote: ↑Mon Nov 28, 2022 10:50 am คลิก Search HN ข้อมูลจะแสดงทั้งหมด ไม่ได้แสดง HN ที่ค้นหา
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
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
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
นำ
j = j + 1
ไปไว้บรรทัดล่างของ Next i
ครับคอลัมน์ไหนคือ Ref ครับwisitsakbenz wrote: ↑Wed Nov 30, 2022 11:01 am อยากให้ผลลัพธ์แสดง Ref มากไปยังน้อย
ต้องปรับ 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
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
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
-ลบบรรทัดแรกแล้ว ได้ผลตามต้องการแล้วครับsnasui wrote: ↑Wed Nov 30, 2022 4:10 pm ผมสังเกตไฟล์ All Data Estimated.xlsx บรรทัดแรกไม่ใช่หัวคอลัมน์ ให้ลบบรรทัดนั้นทิ้งไปเพราะมันจะไม่เป็น Database ทำให้เขียน SQL ยุ่งยากขึ้นกว่าเดิม เช่นต้องเพิ่ม Range ตามเข้ามาด้วย
ในการบ้นทึกกลับไปจะต้องตัดสินใจว่าบันทึกเพิ่มเข้าไปหรือว่าเป็นการ Update รายการเดิม มันต้องมี Where Clause ด้วยครับ นอกจากนี้หากบันทึกครั้งละหลายรายการจะต้อง Loop เข้าไปทีละรายการใส่เข้าที่ Statement Insert หรือ Update ครับ
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
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$
เป็นชื่อชีตที่ใช้จริงrs.Open sql, sCnstr
จากโพสต์ที่ 18 ไม่สามารถวางค่าในไฟล์ที่ปิดได้ด้วยวิธีการนี้ ลบทิ้งไปได้เลยยกเว้นด้านล่างครับSet sCnstr = Nothing
Set rs = Nothing
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