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)
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)
Không phải thủ công thì làm tự động bằng code vậy. Bạn tìm kiếm trên diễn đàn với từ khóa "tổng hợp dữ liệu từ nhiều file" sẽ có rất nhiều kết quả để tham khảo.
Không phải thủ công thì làm tự động bằng code vậy. Bạn tìm kiếm trên diễn đàn với từ khóa "tổng hợp dữ liệu từ nhiều file" sẽ có rất nhiều kết quả để tham khảo.
Không phải thủ công thì làm tự động bằng code vậy. Bạn tìm kiếm trên diễn đàn với từ khóa "tổng hợp dữ liệu từ nhiều file" sẽ có rất nhiều kết quả để tham khảo.
Demo một cái thế này vậy. Bạn mở file A, nhấn nút lệnh, chọn file nguồn, nếu chọn file nào thì dữ liệu trên Sheet1 của file ấy sẽ được chép vào Sheet1 của file A.
Code như sau:
[GPECODE=vb]Sub CopyTuFileKhac()
With Application.FileDialog(1)
.InitialFileName = ThisWorkbook.Path
.Title = "Chon file nguon"
.FilterIndex = 3
.AllowMultiSelect = False
Do
.Show
If .SelectedItems.Count = 0 Then Exit Sub
If .SelectedItems(1) = ThisWorkbook.FullName Then MsgBox "Khong chon file nay!"
Loop Until .SelectedItems(1) <> ThisWorkbook.FullName
With Workbooks.Open(.SelectedItems(1))
.Sheets(1).Cells.Copy ThisWorkbook.Sheets(1).[A1]
.Close False
End With
End With
End Sub[/GPECODE]
Demo một cái thế này vậy. Bạn mở file A, nhấn nút lệnh, chọn file nguồn, nếu chọn file nào thì dữ liệu trên Sheet1 của file ấy sẽ được chép vào Sheet1 của file A.
Code như sau:
[GPECODE=vb]Sub CopyTuFileKhac()
With Application.FileDialog(1)
.InitialFileName = ThisWorkbook.Path
.Title = "Chon file nguon"
.FilterIndex = 3
.AllowMultiSelect = False
Do
.Show
If .SelectedItems.Count = 0 Then Exit Sub
If .SelectedItems(1) = ThisWorkbook.FullName Then MsgBox "Khong chon file nay!"
Loop Until .SelectedItems(1) <> ThisWorkbook.FullName
With Workbooks.Open(.SelectedItems(1))
.Sheets(1).Cells.Copy ThisWorkbook.Sheets(1).[A1]
.Close False
End With
End With
End Sub[/GPECODE]
Thầy có thể hướng dẫn thêm 2 nội dung được ko ạh:
- cho phép chọn file nguồn (có thể ko cùng folder)
- e chỉ muốn copy 1 mảng nào đó từ nguồn, ví dụ: B2100 chẳng hạn
E cảm ơn ạh
Thầy có thể hướng dẫn thêm 2 nội dung được ko ạh:
- cho phép chọn file nguồn (có thể ko cùng folder)
- e chỉ muốn copy 1 mảng nào đó từ nguồn, ví dụ: B2100 chẳng hạn
E cảm ơn ạh
Sub DataCopy() Dim KetquachuoiFile As String
Dim KetquaFile As Workbook
Dim Thoat As Label
'Bây lôi khi không chon file hoac chon không dung
On Error GoTo Thoat
Application.ScreenUpdating = False
'Chon vung nguôn du liêu dê copy (thay dôi tuy y muôn) With Crystalviewer .Range("AS1:BC10000").Select
Selection.Copy
End With
'Lay duong dan va mo file Ket qua
KetquachuoiFile = Application.GetOpenFilename
Set KetquaFile = Workbooks.Open(Filename:=KetquachuoiFile)
'Dan kêt qua copy With KetquaFile .Sheets("P22").Activate
'Chon ô dê paste .Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Close SaveChanges:=True
End With
Sheets("report").Select
Application.CutCopyMode = xlNone
Application.ScreenUpdating = True
Set KetquaFile = Nothing
Exit Sub
Đoạn CODE như này có j sai ko thầy? khi mà e click ko có tác dụng
E lấy mảng từ AS1:BC10000 1 sheets có tên Crystalviewer --> copy vào A1 sheet "P22"
hjk
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?
Đoạn CODE như này có j sai ko thầy? khi mà e click ko có tác dụng
E lấy mảng từ AS1:BC10000 1 sheets có tên Crystalviewer --> copy vào A1 sheet "P22"
hjk
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?
Dạ..trường hợp 1 ạh..vì import dữ liệu ạh..tức là có 1 nút lệnh copy ở 1 file đang mở lấy dữ liệu từ 1 file khác và copy vào 1 sheet nào đó từ file đang mở
p/s: ôi..văn viết. Hjk
Dạ..trường hợp 1 ạh..vì import dữ liệu ạh..tức là có 1 nút lệnh copy ở 1 file đang mở lấy dữ liệu từ 1 file khác và copy vào 1 sheet nào đó từ file đang mở
p/s: ôi..văn viết. Hjk
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 Object
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é
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(UBound(arr, 1) + 1, UBound(arr, 2) + 1).Value = arr
MsgBox "Data has been successfully imported!"
End If
End If
End Sub
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 ạ!
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 ạ!
Sub Main2()
Dim Target as Range, FileName as String, SheetName as String, RangeAddress as String
Set Target = ThisWorkbook.Sheets(1).Range("A1")
FileName = "D:\DuLieu\B.xls"
SheetName = "Sheet3"
RangeAddress = "C1:H10"
[B]GetDataFromRS[/B] Target, FileName, SheetName, RangeAddress
MsgBox "Data has been successfully imported!"
End Sub
Cái này chỉ chổ nó dữ liệu "đáp xuống" luôn (chính là biến Target)
(thử xem, tôi viết đại, chưa test)
----------------
Các bạn cần nên đặt 1 câu hỏi: Khi nào thì nên dùng hàm GetData và khi nào thì nên dùng Sub GetDataFromRS? ---> Thế mới hiểu sâu vấn đề
Sub Main2()
Dim Target as Range, FileName as String, SheetName as String, RangeAddress as String
Set Target = ThisWorkbook.Sheets(1).Range("A1")
FileName = "D:\DuLieu\B.xls"
SheetName = "Sheet3"
RangeAddress = "C1:H10"
[B]GetDataFromRS[/B] Target, FileName, SheetName, RangeAddress
MsgBox "Data has been successfully imported!"
End Sub
Cái này chỉ chổ nó dữ liệu "đáp xuống" luôn (chính là biến Target)
(thử xem, tôi viết đại, chưa test)
----------------
Các bạn cần nên đặt 1 câu hỏi: Khi nào thì nên dùng hàm GetData và khi nào thì nên dùng Sub GetDataFromRS? ---> Thế mới hiểu sâu vấn đề
Ôi, không chạy được Thầy ạ, Có lẽ con áp dụng không đúng cách.
Thầy xem lại cách 3 giúp con với ạ.
Còn câu hỏi của Thầy đặt ra đúng là rất hay. Chắc là cũng phải tùy từng trường hợp nào thì vận dụng cách này hoặc cách kia để thể hiện ưu điểm nó.
Nhưng con chỉ biết áp dụng thôi, còn đọc code con chịu thua nên không chưa thể trả lời câu hỏi trên.
Thầy chỉ giáo ạ!
Cảm ơn Thầy!
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 [COLOR=#ff0000]ADODB.Recordset[/COLOR]
......
End Sub
thành vầy:
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 [COLOR=#ff0000]Object[/COLOR]
......
End Sub
Còn câu hỏi của Thầy đặt ra đúng là rất hay. Chắc là cũng phải tùy từng trường hợp nào thì vận dụng cách này hoặc cách kia để thể hiện ưu điểm nó.
Nhưng con chỉ biết áp dụng thôi, còn đọc code con chịu thua nên không chưa thể trả lời câu hỏi trên.
Thầy chỉ giáo ạ!
Cảm ơn Thầy!
Thật ra em k bít gì về VBA, nhưng e có viết công thức tính toán gồm 3 sheet: nguồn, tính toán, kết quả.
Em đã thiết kế đều chạy tốt, nhưng phải copy thủ công đưa dữ liệu vào sheet nguồn.
Có cách nào dữ liệu sheet nguồn được lấy từ 1 file khác được k ạ?
Nhấn nút COPY nó hiện hộp thoại ra cho mình chọn file để lấy dữ liệu đó ạ.
Các bác viết dùm em đoạn code cho nút COPY
Cảm ơn tất cả^^
Thật ra em k bít gì về VBA, nhưng e có viết công thức tính toán gồm 3 sheet: nguồn, tính toán, kết quả.
Em đã thiết kế đều chạy tốt, nhưng phải copy thủ công đưa dữ liệu vào sheet nguồn.
Có cách nào dữ liệu sheet nguồn được lấy từ 1 file khác được k ạ?
Nhấn nút COPY nó hiện hộp thoại ra cho mình chọn file để lấy dữ liệu đó ạ.
Các bác viết dùm em đoạn code cho nút COPY
Cảm ơn tất cả^^
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 Object
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é
[COLOR=#000000]Sub Main_OpenFileName()[/COLOR] Dim arr, vFile
[COLOR=#ff0000]vFile = Application.GetOpenFilename("Excel Files, *.xls;*.xlsx;*.xlsm;*.xlsb")[/COLOR]
[COLOR=#ff0000][/COLOR][SIZE=2][COLOR=#ff0000][B]SheetName ="*loan"[/B][/COLOR][/SIZE]
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 [COLOR=#000000]End Sub[/COLOR]
E có sử dụng code của thầy NDU để import dữ liệu
Tại mục SheetName có khai báo *loan để lấy dữ liệu từ sheet có tên "xxx.loan.xxx" mà ko có được
Làm thế nào để lấy tên tương đối của sheet... Anh/chị giúp e với ạh
Hôm trwowsc thầy NDU có up file tổng hợp. Nhưng em muốn lấy vài dữ liệu ở sheet VD: ô A10, ô B13, ô C14 .. vào 1 dòng trong file tông hợp, thầy có thể sửa giúp em được không ah,E cảm ơn
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 Object
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é
-- thầy có thể cải tiến hàm này thêm một bậc nữa là có 1 tùy chọn được không ạ, có thể chọn lấy dữ liệu từ file đóng vào file đang mở hoặc ghi dữ liệu từ file đang mở vào file đã đóng, cám ơn thầy
Vậy thì dùng ADO mới là vô địch. Tặng bạn 2 code này:
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é
Cho em hỏi phần arr = GetData(CStr(vFile)), em có viết lại là arr = GetData(CStr(vFile), SheetName) với Sheetname là tên sheets em cần lấy. Nhưng khi chạy code báo lỗi, không biết có phải ở code này thì viết thế là sai cú pháp không ạ?
Cho em hỏi phần arr = GetData(CStr(vFile)), em có viết lại là arr = GetData(CStr(vFile), SheetName) với Sheetname là tên sheets em cần lấy. Nhưng khi chạy code báo lỗi, không biết có phải ở code này thì viết thế là sai cú pháp không ạ?
100 chẳng hạn
