E có 2 file excel (A và B), giả sử 2 file này đều nằm trong một folder
Sự kiện: đang mở file A, có marco nào có thể tự động copy dữ liệu sheet1 của B sang sheet1 của A (không phải thủ công: mở file B -> bôi đen -> ctrl C -> paste sang A)
Lúc đầu tôi thấy tác giả hỏi cách để LẤY DỮ LIỆU TỪ FILE ĐANG ĐÓNG VÀO FILE ĐANG MỞ (1)
Còn code của thầy hình như làm ngược lạ: COPY DỮ LIỆU TỪ FILE ĐANG MỞ VÀO FILE ĐANG ĐÓNG (2)
Hay tác giả thay đổi chủ ý?
Tóm lại: Tác giả cần trường hợp nào? (1) hay (2) vậy?
Hê hê, em đọc không kỹ! Đơn giản hơn thì mở ngầm như em đã làm.
Sub Main_OpenFileName() Dim arr, vFile
vFile = Application.GetOpenFilename("Excel Files, *.xls;*.xlsx;*.xlsm")
SheetName = "Crystalviewer"
RangeAddress = "AS1:BC10000"
If TypeName(vFile) = "String" Then
arr = GetData(vFile, SheetName, RangeAddress)
If IsArray(arr) Then
ThisWorkbook.Sheets("P22").Range("A1").Resize(UBou nd(arr, 1) + 1, UBound(arr, 2) + 1).Value = arr
MsgBox "Data has been successfully imported!"
End If
End If
End Sub
Sub Main_OpenFileName() Dim arr, vFile
vFile = Application.GetOpenFilename("Excel Files, *.xls;*.xlsx;*.xlsm")
SheetName = "Crystalviewer"
RangeAddress = "AS1:BC10000"
If TypeName(vFile) = "String" Then
arr = GetData(vFile, SheetName, RangeAddress)
If IsArray(arr) Then
ThisWorkbook.Sheets("P22").Range("A1").Resize(UBou nd(arr, 1) + 1, UBound(arr, 2) + 1).Value = arr
MsgBox "Data has been successfully imported!"
End If
End If
End Sub
Thì vâng! Code ở bài 19 có bẫy lỗi vậy đấy: Nếu đóng cửa sổ OpenFile hoặc bấm Cancel thì nó sẽ không làm gì cả. Câu lệnh để bẫy lỗi là vầy
Mã:
vFile = Application.GetOpenFilename("Excel Files, *.xls;*.xlsx;*.xlsm;*.xlsb")
[COLOR=#ff0000]If TypeName(vFile) = "String" Then [/COLOR]
Làm công việc Import
[COLOR=#ff0000]End If[/COLOR]
Còn code mà thầy nói là người ta "chế" lại, bỏ mất đoạn bẫy lỗi đi rồi
-------------------------------
Sẽ khác nếu như hộp OpenFile mở ra nhưng bạn lại không chọn file nào mà bấm nút Cancel
Thử sẽ biết
Theo nhận định của tôi: Viết code đã khó mà bẫy lỗi để lường trước mọi trường hợp trục trặc phát sinh lại càng khó gấp trăm lần
Thì vâng! Code ở bài 19 có bẫy lỗi vậy đấy: Nếu đóng cửa sổ OpenFile hoặc bấm Cancel thì nó sẽ không làm gì cả. Câu lệnh để bẫy lỗi là vầy
Mã:
vFile = Application.GetOpenFilename("Excel Files, *.xls;*.xlsx;*.xlsm;*.xlsb")
[COLOR=#ff0000]If TypeName(vFile) = "String" Then [/COLOR]
Làm công việc Import
[COLOR=#ff0000]End If[/COLOR]
Còn code mà thầy nói là người ta "chế" lại, bỏ mất đoạn bẫy lỗi đi rồi
-------------------------------
Sẽ khác nếu như hộp OpenFile mở ra nhưng bạn lại không chọn file nào mà bấm nút Cancel
Thử sẽ biết
Theo nhận định của tôi: Viết code đã khó mà bẫy lỗi để lường trước mọi trường hợp trục trặc phát sinh lại càng khó gấp trăm lần
Vẫn nên khuyên là em tự học đi, nếu còn gắn bó với Excel và VBA thì chịu khó nghiên cứu để phát triển. Code của bác ndu đưa ra thì là 1 sản phẩm nâng cao rồi, đọc không dễ hiểu.
Vẫn nên khuyên là em tự học đi, nếu còn gắn bó với Excel và VBA thì chịu khó nghiên cứu để phát triển. Code của bác ndu đưa ra thì là 1 sản phẩm nâng cao rồi, đọc không dễ hiểu.
Vậy thì dùng ADO mới là vô địch. Tặng bạn 2 code này:
Mã:
Function GetData(ByVal FileName As String, Optional ByVal SheetName As String = "", Optional ByVal RangeAddress As String = "")
Dim cnn As Object, rsData As Object
Dim tmpArr, arr
Dim szConn As String, szSQL As String, tmp As String
Dim lR As Long, lC As Long, lVersn As Long
On Error GoTo ErrHandler
lVersn = Val(Application.Version)
Set cnn = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
If lVersn < 12 Then
szConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";IMEX=1;"
Else
szConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
"Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
End If
If SheetName = "" Then
Dim Dbs As Object, db As Object
Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVersn < 12, "36", "120"))
Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
tmp = db.TableDefs(0).Name
tmp = Replace(tmp, "''", "'")
SheetName = tmp
db.Close
Set Dbs = Nothing: Set db = Nothing
Else
SheetName = SheetName & "$"
End If
cnn.Open szConn
szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
rsData.Open szSQL, cnn, 1, 1
tmpArr = rsData.GetRows
ReDim arr(UBound(tmpArr, 2), UBound(tmpArr, 1))
rsData.Close: cnn.Close
For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
arr(lR, lC) = tmpArr(lC, lR)
Next
Next
GetData = arr
Set rsData = Nothing: Set cnn = Nothing
Exit Function
ErrHandler:
MsgBox Err.Description
Set rsData = Nothing: Set cnn = Nothing
End Function
Mã:
Sub GetDataFromRS(ByVal Target As Range, ByVal FileName As String, Optional ByVal SheetName As String = "", Optional ByVal RangeAddress As String = "")
Dim cnn As Object, rsData As ADODB.Recordset
Dim szConn As String, szSQL As String, tmp As String
Dim lR As Long, lC As Long, lVersn As Long
On Error GoTo ErrHandler
lVersn = Val(Application.Version)
Set cnn = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
If lVersn < 12 Then
szConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";IMEX=1;"
Else
szConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
"Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
End If
If SheetName = "" Then
Dim Dbs As Object, db As Object
Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVersn < 12, "36", "120"))
Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
tmp = db.TableDefs(0).Name
tmp = Replace(tmp, "''", "'")
SheetName = tmp
db.Close
Set Dbs = Nothing: Set db = Nothing
Else
SheetName = SheetName & "$"
End If
cnn.Open szConn
szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "]"
'szSQL = "SELECT [F2],[F4] FROM [" & SheetName & RangeAddress & "] WHERE F1>5 AND F3 = 'ELECTRIC'"
rsData.Open szSQL, cnn, 1, 1
Target.CopyFromRecordset rsData
rsData.Close: cnn.Close
Set rsData = Nothing: Set cnn = Nothing
MsgBox "Data has been successfully imported!"
Exit Sub
ErrHandler:
MsgBox Err.Description
Set rsData = Nothing: Set cnn = Nothing
End Sub
Tùy chọn xài 1 trong 2 cái nha!
- Cả 2 cái đều có thể dùng trực tiếp trong VBA
- Cái thứ nhất là HÀM, vậy bạn có thể gõ trực tiếp trên bảng tính
- Cái thứ hai là SUB, vậy chỉ có thể dùng trong VBA (không gõ đươc trên bảng tính)
-------------------------------
Phần code ở trên bạn cho vào 1 Module và cũng không cần hiểu, chỉ cần biết áp dụng là đủ
Ví dụ: Bạn chọn áp dụng HÀM
- File dữ liệu đang đóng nằm ở: "D:\DuLieu\B.xls"
- Tên sheet của file dữ liệu là "Sheet3"
- Vùng dữ liệu cần lấy là "C1:H10"
- Vậy ta viết thêm code áp dụng thế này:
Mã:
Sub Main()
Dim FileName as String, SheetName as String, RangeAddress as String
Dim arr
[COLOR=#ff0000]FileName = "D:\DuLieu\B.xls"
SheetName = "Sheet3"
RangeAddress = "C1:H10"[/COLOR]
arr = GetData(FileName, SheetName, RangeAddress)
If IsArray(arr) Then
[COLOR=#0000cd]ThisWorkbook.Sheets(1).Range("A1")[/COLOR].Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1).Value = arr
MsgBox "Data has been successfully imported!"
End If
End Sub
Chỉ cần lưu ý 3 dòng màu đỏ, khai báo cho đúng là được
Chổ màu xanh chính là nơi bạn cần copy đến Lưu ý:
- Nếu bạn chỉ khai báo FileName, không khai báo SheetName, RangeAddress thì đồng nghĩa bạn muốn lấy toàn bộ dữ liệu của sheet đầu tiên
- Trong Sub Main (là Sub áp dụng), phần FileName bạn có thể dùng GetOpenFileName để tùy ý chọn file nguồn. Ví dụ:
Mã:
Sub Main_OpenFileName()
Dim arr, vFile
[COLOR=#ff0000]vFile = Application.GetOpenFilename("Excel Files, *.xls;*.xlsx;*.xlsm")[/COLOR]
If TypeName(vFile) = "String" Then
arr = GetData(CStr(vFile))
If IsArray(arr) Then
ThisWorkbook.Sheets(1).Range("A1").Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1).Value = arr
MsgBox "Data has been successfully imported!"
End If
End If
End Sub
Màu đỏ dùng để mở hộp chọn file. Đoạn code trên không khai báo SheetName và RangeAddress nên code sẽ lấy toàn bộ dữ liệu ở sheet đầu tiên
------------------
Cách dùng cho code Sub GetDataFromRS cũng gần tương tự. Bạn tự khám phá nhé
Dạ, ý e là import cùng lúc sheet1, sheet2.. của file B về sheet1, sheet2.. của file A ah.
Hiện tại, theo hướng dẫn của thầy e đang làm 2 nút import và khai báo thêm sub nữa ạh
Dạ, ý e là import cùng lúc sheet1, sheet2.. của file B về sheet1, sheet2.. của file A ah.
Hiện tại, theo hướng dẫn của thầy e đang làm 2 nút import và khai báo thêm sub nữa ạh
Chào Thầy ạ!
Bài này của Thầy hấp dẫn quá! hihi
Khi nào Thầy ranh rảnh vì chưa có bài viết nào thì Thầy tạo giúp con nốt cái Main_2 cho Sub GetDataFromRS Thầy nhé!
Hi, Cảm Thầy ạ!
