copy data có Link tu workbook dang dong

[lexthien]

Chào cả nhà !
Mình có đoạn code cho phép copy dữ liệu của 1 sheet từ 1 workbbok đang đóng như sau:
1/ Function
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
sourceRange As String, TargetRange As Range, HeaderRow As Boolean)
Dim rsData As ADODB.Recordset
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long

If Range(sourceRange).Rows.Count = 1 Then
' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
End If

szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & sourceRange$ & "];"

On Error GoTo SomethingWrong

Set rsData = New ADODB.Recordset
rsData.Open szSQL, szConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText

' Check to make sure we received data and copy the data
If Not rsData.EOF Then

If Range(sourceRange).Rows.Count = 1 Then
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If HeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
End If

Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If

' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
Exit Sub

SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

Function Array_Sort(ArrayList As Variant) As Variant
Dim aCnt As Integer, bCnt As Integer
Dim tempStr As String

For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
For bCnt = aCnt + 1 To UBound(ArrayList)
If ArrayList(aCnt) > ArrayList(bCnt) Then
tempStr = ArrayList(bCnt)
ArrayList(bCnt) = ArrayList(aCnt)
ArrayList(aCnt) = tempStr
End If
Next bCnt
Next aCnt
Array_Sort = ArrayList
End Function

2/
Sub GetData_Example()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant, N As Long
Dim rnum As Long, destrange As Range
Dim sh As Worksheet

SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", _
MultiSelect:=True)
If IsArray(FName) Then
' Sort the Array
FName = Array_Sort(FName)

Application.ScreenUpdating = False
'Add worksheet to the Activeworkbook and use the Date/Time as name
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = Format(Now, "dd-mm-yy h-mm-ss")

'Loop through all files you select in the GetOpenFilename dialog
For N = LBound(FName) To UBound(FName)

'Find the last row with data
rnum = LastRow(sh)

'create the destination cell address
Set destrange = sh.Cells(rnum + 1, "A")

' For testing Copy the workbook name in Column E
sh.Cells(rnum + 1, "E").Value = FName(N)


'Get the cell values and copy it in the destrange
'Change the Sheet name and range as you like
'Set the last argument to True if you want to copy the header row also
GetData FName(N), "NKC", "A12500", destrange, False
Next

End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

Nhưng dữ liệu copy được sang sheet hiện hành thì chỉ có text và giá trị, những ô chứa dữ liệu có link các với các ô khác hoặc sheet khác thì lại không copy sang được, tại sheet hiện hành toàn là dòng trắng.
Mong các cao thủ giúp tôi:
- copy y dữ liệu.
- các định dạng ô dòng được giữ nguyên.
Xin giúp tôi với.
Thân chào

 

[Đào Việt Cường]

Dear lexthien,
-------------
Trước khi bàn về vấn đề "copy data có Link tu workbook dang dong", mình xin nhận xét thế này: việc sử dụng ADODB trong MS Excel VBA giống như chúng ta dùng công cụ sửa chữa một cái máy cày để sửa chữa một cái cày vậy! Tất nhiên, ở một số chức năng, công cụ này tỏ ra hiệu quả và đáng để chúng ta khai thác, nhưng phần lớn ADODB là một tập hợp lập trình tiên tiến, áp dụng cho các mô hình cơ sở dữ liệu quan hệ (có các table, các relationship, các recordset... thực thụ).
Khai thác được thế mạnh của ADODB ứng dụng vào MS Excel là một điều rất tốt. Tuy nhiên, trong trường hợp này phải hết sức cảnh giác: có thể công việc của chúng ta sẽ phải làm nhiều hơn so với kết quả mà chúng ta muốn đạt được. Ý ở đây là chúng ta thay vì tìm tòi để hiểu biết rõ công năng của "công cụ chữa cái máy cày" thì hãy khai thác triệt để công năng của "công cụ chữa cái cày". Đương nhiên rồi, đồ nào - nghề đó (thì mới gọi là "đồ nghề").
Nếu lexthien đã từ sử dụng chức năng Import External Data trong MS Excel thì thấy vấn đề copy data có Link tu workbook dang dong cực kỳ đơn giản, không cần viết một "đoạn VBA" nào! (nếu không muốn tùy biến thêm).
Sử dụng chức năng Import External Data thực chất chúng ta nhờ một "nhà cung cấp" (Provider) kết nối tới một cơ sở dữ liệu bên ngoài. MS Excel cung cấp cho chúng ta tập hợp QueryTables và phương thức Add để tạo mới một kết nối. Tập hợp này thuộc lớp đối tượng Worksheet:
<Worksheet>.QueryTables.Add
Điểm đáng lưu ý ở đây là MS Excel cho chúng ta 2 Providers để chúng ta làm việc. Việc lựa chọn nhà cung cấp nào phụ thuộc vào phương thức kết nối: Kết nối trực tiếp tới cơ sở dữ liệu hay sử dụng truy vấn (Query). Điều này cũng quyết định phương thức kết nối rất rõ rệt. Tham khảo ví dụ sau:

'This example creates a new PivotTable cache based on an OLAP provider, and then it creates a new PivotTable report 'based on the cache, at cell A3 on the active worksheet.

With ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)
.Connection = _
"OLEDB;Provider=MSOLAP;Location=srvdata;Initial Catalog=National"
.MaintainConnection = True
.CreatePivotTable TableDestination:=Range("A3"), _
TableName:= "PivotTable1"
End With
With ActiveSheet.PivotTables("PivotTable1")
.SmallGrid = False
.PivotCache.RefreshPeriod = 0
With .CubeFields("[state]")
.Orientation = xlColumnField
.Position = 0
End With
With .CubeFields("[Measures].[Count Of au_id]")
.Orientation = xlDataField
.Position = 0
End With
End With

______________________________________________
'This example supplies new ODBC connection information for the first query table on the first worksheet.

Worksheets(1).QueryTables(1) _
.Connection:="ODBC;DSN=96SalesData;UID=Rep21;PWD=NUyHwYQI;"

'This example specifies a text file.
Worksheets(1).QueryTables(1) _
Connection := "TEXT;C:\My Documents\19980331.txt"

Điểm đáng chú ý của các kết nối này là dữ liệu "Read - only" - chỉ đọc mà thôi (không biết có đúng không). Tất nhiên việc thay đổi dữ liệu nguồn sẽ ảnh hưởng đến kết quả mà ta import.
Nếu muốn tìm hiểu sâu hơn về vấn đề này, bạn hãy ghi lại một macro thực hiện lệnh Data/Import External Data/ Import Data hoặc New Database Query.
Thiết nghĩ ứng dụng như vầy mới mang màu sắc VBA hơn!

 

[lexthien]

Hi Daovietcuong
Rất cảm ơn sự quan tâm của bạn.
Quả thật excel đã có sẵn chức năng Data/Import External Data/ Import Data rất hay, nhưng kết quả cho ra vẫn không giải quyết được khúc mắc sau:
- Dữ liệu Import vào vẫn không đầy đủ tất cả như đã nêu (những ô chức dữ liệu link vẫn không được lấy vào, dù chỉ dưới dạng giá trị).
- Các định dạng vẫn không được giữ nguyên như sheet được lấy dữ liệu

PS: đoạn code nối sheet của bạn rất hay:
Private Sub CopyTo()
Dim lngRowCount As Long ' Biến đếm số dòng sau mỗi lần copy
Dim shCHITIET As Worksheet,shTONGHOP As Worksheet
Set shTONGHOP = Worksheets("TONGHOP")
shTONGHOP.Cells.ClearContents
lngRowCount = 9
For Each shCHITIET In ThisWorkbook.Worksheets
If Not shCHITIET Is shTONGHOP Then
shCHITIET.UsedRange.Copy
shTONGHOP.Range("A" & lngRowCount).PasteSpecial
lngRowCount = lngRowCount + shCHITIET.UsedRange.Rows.Count
End If
Next
End Sub

Nhưng có cách nào cho hiện 1 from cho phép chọn số lượng sheet nối lại hay không?

Mong bạn giành ít thời gian giúp mình
Thân chào bạn.