copy data có Link tu workbook dang dong

Thảo luận trong 'Ứng dụng Excel' bắt đầu bởi lexthien, 15 Tháng ba 2006.

2,919 lượt xem

  1. lexthien

    lexthien Thành viên thân thiết

    Bài viết:
    77
    Đã được thích:
    1
    Nơi ở:
    TPHCM
    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", "A1:eek:2500", 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
     
    #1
  2. Đào Việt Cường

    Đào Việt Cường Moderator

    Bài viết:
    400
    Đã được thích:
    3
    Giới tính:
    Nam
    Nơi ở:
    Khánh Hòa
    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:
    Đ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!
     
    Last edited: 15 Tháng ba 2006
    #2
  3. lexthien

    lexthien Thành viên thân thiết

    Bài viết:
    77
    Đã được thích:
    1
    Nơi ở:
    TPHCM
    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.
     
    #3

Chia sẻ trang này