Làm biếng viết code mới nên "chế" lại code của bạn một chút như sau:
Sub Copy_Data()
Dim mybook As Workbook, basebook As String, fname As String, Mypath As String
Application.ScreenUpdating = False
Mypath = Application.ActiveWorkbook.Path
basebook = ActiveWorkbook.Name
ChDrive Mypath: ChDir Mypath
fname = Application.GetOpenFilename(filefilter:="Execel files (*.xls), *.xls", Title:="Chon file nguon", MultiSelect:=False)
If fname = "False" Then Exit Sub
Set mybook = Workbooks.Open(fname)
ThisWorkbook.Sheets("MPSap2000").[A4:H6500].Value = mybook.Sheets("Element Forces - Frames").[A4:H6500].Value
mybook.Close False
Application.ScreenUpdating = True
End Sub
Sub HLMT_ADO()
Dim Cn As New ADODB.Connection
Dim mySQL As String
mySQL = "UPDATE [Program Control$] a " _
& "INNER JOIN " _
& "[Excel 8.0;HDR=No;IMEX=2;DATABASE=" & ThisWorkbook.FullName & "].[data] b " _
& "ON a.F1=b.F1 " _
& "SET b.F3=val(Mid(a.F5,2,2)) , b.F4=val(Right(a.F5,2))"
[L4:M6000].ClearContents
With Cn
.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & _
"\bang noi luc.xls;Extended Properties=""Excel 8.0;HDR=No;"";"
.Execute mySQL
.Close
End With
Set Cn = Nothing
End SubBạn sử dụng code sau nhé.
Sub HLMT_ADO()
On Error GoTo loi
Dim Cn As New ADODB.Connection
Dim mySQL As String, strFile As Variant
strFile = Application.GetOpenFilename()
If strFile <> False Then
mySQL = "UPDATE [Program Control$] a " _
& "INNER JOIN " _
& "[Excel 8.0;HDR=No;IMEX=2;DATABASE=" & ThisWorkbook.FullName & "].[data] b " _
& "ON a.F1=b.F1 " _
& "SET b.F3=val(Mid(a.F5,2,2)) , b.F4=val(Right(a.F5,2))"
[L4:M6000].ClearContents
With Cn
.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strFile & _
";Extended Properties=""Excel 8.0;HDR=No;"";"
.Execute mySQL
.Close
End With
End If
Set Cn = Nothing
Exit Sub
loi:
MsgBox Err.Description
End Sub
