Giúp đỡ code import file xml vào excel

Chia sẻ bởi:hands

★★★★★

‹ Help!! Có cách nào đưa dữ liệu... Lấy dữ liệu từ file excel khác... ›

Quảng cáo

Em đang có một chút khó khăn nhờ các thầy giúp đỡ.
Các thầy có thể hướng dẫn giúp em tạo một nút bấm để mở một file xml trong 1 ổ đĩa bất kỳ trên máy tính.
sau đó import vào sheet 2 được không ạ.
Em đã thử dùng openfile dialog mở được nhưng không import dữ liệu được.

Code này thầy NDU có hướng dẫn tôi, bạn tham khảo nhé (ko phải mở file mà import trực tiếp luôn):
Copy code này vào 1 module:

Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _
ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)

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=" & IIf(HasTitle, "Yes", "No") & ";IMEX=1"";"
    Else
        szConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
        "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "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) - UseTitle, UBound(tmpArr, 1))
    If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
    Arr(0, lC) = rsData.Fields(lC).Name
    Next
    End If
    rsData.Close: cnn.Close
    For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
    Arr(lR - UseTitle, 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

Còn sau đây là thủ tục để import:

Sub Main()
  Dim FileName As String, SheetName As String, RangeAddress As String
  Dim Arr
  FileName = "[B][COLOR=#ff0000].......xml[/COLOR][/B]" '<-- bạn khai báo đường dẫn và tên file
  SheetName = "[COLOR=#ff0000][B]123[/B][/COLOR]" '<- tên sheet muốn import
  RangAddress = "[COLOR=#ff0000][B]A1:B500[/B][/COLOR]" '<- Mảng muốn import
  Arr = GetData(FileName, SheetName, RangeAddress, True, True)
    If IsArray(Arr) Then
      ThisWorkbook.Sheets("[COLOR=#ff0000][B]Sheet2[/B][/COLOR]").Range("[B][COLOR=#ff0000]A1[/COLOR][/B]").Resize(UBound(Arr, 1) + 1, _
      UBound(Arr, 2) + 1).Value = Arr

End If

End Sub

Bạn thử xem có được ko? Nếu ko pốt file lên để mng giúp bạn…

Bạn có thể tham khảo và nghiên cứi thêm ở topic này:
https://www.giaiphapexcel.com/forum/showthread.php?86477-Import-d%E1%BB%AF-li%E1%BB%87u

P/S: cái này phải dùng VBA mới được.. nên topic này chuyển về box lập trình với excel thì đùng hơn…

Bữa mình cũng có xem qua bài này rồi nhưng tại vì cũng mới làm quen với VBA nên hơi khó hiểu.
Cám ơn bạn đã giúp đỡ. 🙂

Mình cũng chỉ biết LÁI thôi mà, có nghĩ ra được đâu.. bạn thử áp dụng xem.
Mở file excel, dùng tổ hợp ALT + F11 để mở của sổ soạn thảo VBA,vào tab insertmodule -> copy 2 đoạn code kia vào -> sửa mấy chỗ mình bôi đỏ..
Chúc thành công