Giúp em lấy dữ liệu từ các file nằm ở các folder khác nhau theo đường dẫn

Liên hệ QC
V

vonguyen3745

Thành viên hoạt động
Tham gia
18/7/09
Bài viết
145
Được thích
5
Em có các file nằm ở các thư mục khác nhau, muốn lấy dữ liệu về 1 file tổng hợp. Các file này có sẵn đường dẫn, sheets cần lấy và vùng cần lấy dữ liệu. Thanks
 

File đính kèm

  • HANGTAU.rar
    58.6 KB · Đọc: 32
Sắp xếp theo thời gian sắp xếp theo bầu chọn
vonguyen3745 đã viết:
Em có các file nằm ở các thư mục khác nhau, muốn lấy dữ liệu về 1 file tổng hợp. Các file này có sẵn đường dẫn, sheets cần lấy và vùng cần lấy dữ liệu. Thanks
Nhấp chuột vào đây để mở rộng...
Chạy sub
Mã: 
Sub ABC()
  Dim sArr(), cn As Object, fRow&
  With Sheets("Sheet1")
    sArr = .Range("A2", .Range("C" & Rows.Count).End(xlUp)).Value
  End With
  Set cn = CreateObject("ADODB.Connection")
  On Error Resume Next
  With Sheets("Sheet2")
    For i = 1 To UBound(sArr)
      fRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
      cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sArr(i, 1) & ";Extended Properties=""Excel 12.0;HDR=No"";"
      .Range("A" & fRow).CopyFromRecordset cn.Execute("select * from [" & sArr(i, 2) & "$" & sArr(i, 3) & "] where f1 is not null")
      cn.Close
    Next i
  End With
  Set cn = Nothing
End Sub
 
Upvote 0
Thanks bác HieuCD! Em muốn lấy thêm tên fie để biết dữ liệu đó từ file nào được không bác. Cảm ơn bác rất nhiều ạ.
 
Lần chỉnh sửa cuối:
Upvote 0
vonguyen3745 đã viết:
Thanks bác HieuCD! Em muốn lấy thêm tên fie để biết dữ liệu đó từ file nào được không bác. Cảm ơn bác rất nhiều ạ.
Nhấp chuột vào đây để mở rộng...
Bạn thử thế này:
SQL: 
Sub ABC()
  Dim sArr(), cn As Object, fRow&
  With Sheets("Sheet1")
    sArr = .Range("A2", .Range("C" & Rows.Count).End(xlUp)).Value
  End With
  Set cn = CreateObject("ADODB.Connection")
  On Error Resume Next
  With Sheets("Sheet2")
    For i = 1 To UBound(sArr)
      fRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
      cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sArr(i, 1) & ";Extended Properties=""Excel 12.0;HDR=No"";"
      .Range("A" & fRow).CopyFromRecordset cn.Execute("select *,'" & sArr(i, 1) & "' from [" & sArr(i, 2) & "$" & sArr(i, 3) & "] where f1 is not null")
      cn.Close
    Next i
  End With
  Set cn = Nothing
End Sub
 
Upvote 0
quick87 đã viết:
Bạn thử thế này:
SQL: 
Sub ABC()
  Dim sArr(), cn As Object, fRow&
  With Sheets("Sheet1")
    sArr = .Range("A2", .Range("C" & Rows.Count).End(xlUp)).Value
  End With
  Set cn = CreateObject("ADODB.Connection")
  On Error Resume Next
  With Sheets("Sheet2")
    For i = 1 To UBound(sArr)
      fRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
      cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sArr(i, 1) & ";Extended Properties=""Excel 12.0;HDR=No"";"
      .Range("A" & fRow).CopyFromRecordset cn.Execute("select *,'" & sArr(i, 1) & "' from [" & sArr(i, 2) & "$" & sArr(i, 3) & "] where f1 is not null")
      cn.Close
    Next i
  End With
  Set cn = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Cái này nếu sheets 2 có dữ liệu nó không ghi đè lên bác nhỉ, khi các file họ cập nhật số liệu, mình muốn lấy dữ liệu mới không được, em muốn sheet 2 có dữ liệu rồi nó ghi đè lên dữ liệu cũ khi mình chạy code được không bác.
 
Upvote 0
vonguyen3745 đã viết:
Cái này nếu sheets 2 có dữ liệu nó không ghi đè lên bác nhỉ, khi các file họ cập nhật số liệu, mình muốn lấy dữ liệu mới không được, em muốn sheet 2 có dữ liệu rồi nó ghi đè lên dữ liệu cũ khi mình chạy code được không bác.
Nhấp chuột vào đây để mở rộng...

Bạn chỉnh lại điều kiện ở sheet1 là được mà ?
1626597863798.png

Code đã tự động điền giá trị cần lấy và nối tiếp dòng cuối cùng rồi.
 
Upvote 0
- Ý em là ở sheet đích, nếu có sẵn dữ liệu rồi thì code nó không copy đè lên dữ liệu ở đó.
- Em muốn chỉnh ô đầu tiên dán dữ liệu thì chỉnh thế nào bác, nó mặc định là ô A2, nhiều khi phần tiêu đề nó có 3-4 dòng thì lại không chạy được
 
Lần chỉnh sửa cuối:
Upvote 0
1.jpeg
Em chỉnh ô bắt đầu paste dữ liệu ở chỗ dánh dấu kia thì dữ liệu sau khi gộp từ các file nó lại có khoảng trống,
 
Lần chỉnh sửa cuối:
Upvote 0
vonguyen3745 đã viết:
Em có các file nằm ở các thư mục khác nhau, muốn lấy dữ liệu về 1 file tổng hợp. Các file này có sẵn đường dẫn, sheets cần lấy và vùng cần lấy dữ liệu. Thanks
Nhấp chuột vào đây để mở rộng...
Một cách làm khác, bạn tham khảo thêm:

Mã: 
Option Explicit

Dim sFile  As String
Sub DataLink(ByRef cell_ As Range, ByVal sLink As String, ByVal sFileName As String)
    On Error GoTo Err_
    cell_.FormulaArray = sLink: cell_.Value = cell_.Value
    If Len(sFile) = 0 Then sFile = sFileName Else sFile = sFile & vbNewLine & sFileName
Err_:
End Sub

Sub RunMe()

    Dim sheet As Worksheet, start_cell As Range, cell_ As Range, str As String, tmp
    Dim sFolder As String, sFileName As String, sShName As String, sRange As String
    Dim sLink As String
    
    Application.ScreenUpdating = False
    Set sheet = Sheet2: sheet.Cells.ClearContents
    Set start_cell = Sheet1.Range("A2")
    sFile = Empty
    Do Until start_cell.Value = ""
        str = start_cell.Value
        tmp = Split(str, "\")
        sFileName = tmp(UBound(tmp))
        sFolder = Mid(str, 1, Len(str) - Len(sFileName) - 1)
        If Len(Dir(sFolder & "\" & sFileName)) > 0 Then
            sShName = start_cell.Offset(, 1).Value
            sRange = start_cell.Offset(, 2).Value
            Set cell_ = sheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
            Set cell_ = cell_.Resize(sheet.Range(sRange).Rows.Count, sheet.Range(sRange).Columns.Count)
            sLink = "='" & sFolder & "\[" & sFileName & "]" & sShName & "'!" & sRange & ""
            DataLink cell_, sLink, sFileName
        End If
        Set start_cell = start_cell.Offset(1)
    Loop
    
    Application.ScreenUpdating = True
    sheet.Activate
    
    If Len(sFile) > 0 Then
        sFile = "File link OK:" & vbNewLine & sFile
    End If
    
    MsgBox "Kêt thúc " & vbNewLine & sFile, vbOKOnly + vbInformation
    
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
vonguyen3745 đã viết:
Khi em chạy code của bác

Hoàng Nhật Phương nó tạo ra dãy số 0 xen giữa các dòng dữ liệu; em không biết dãy đó ở đâu ra nhỉ:​

View attachment 262685
Nhấp chuột vào đây để mở rộng...
Chào Bạn, trong Sub RunMe , Bạn thử sửa dòng:
Mã: 
sLink = "='" & sFolder & "\[" & sFileName & "]" & sShName & "'!" & sRange & ""
Thành:
Mã: 
sLink = "'" & sFolder & "\[" & sFileName & "]" & sShName & "'!" & sRange & ""
sLink = "=IF(" & sLink & "<>""""," & sLink & ","""")"
 
Upvote 0
1.jpeg
OK rồi bạn, mình không muốn paste dữ liệu bắt đầu từ ô A2, mình muốn paste bắt đầu từ ô A4 thì chỉnh thế nào bạn nhỉ?
 
Upvote 0
vonguyen3745 đã viết:
View attachment 262694
OK rồi bạn, mình không muốn paste dữ liệu bắt đầu từ ô A2, mình muốn paste bắt đầu từ ô A4 thì chỉnh thế nào bạn nhỉ?
Nhấp chuột vào đây để mở rộng...
Bạn thử lại RunMe sau:
Mã: 
Sub RunMe()

    On Error GoTo Loi_roi:

    Application.ScreenUpdating = False
    Dim sheet As Worksheet, start_cell As Range, cell_ As Range, str As String, tmp, r As Long
    Dim sFolder As String, sFileName As String, sShName As String, sRange As String, sLink As String
    
    Const tenfile_batdau As String = "A2"
    Const oghidulieu_dautien As String = "A4"
    Const shGhiDuLieu As String = "Sheet2"
    sFile = Empty
    
    Set sheet = ThisWorkbook.Worksheets(shGhiDuLieu)
    sheet.Cells.ClearContents
    Set start_cell = Sheet1.Range(tenfile_batdau)
    
    Do Until start_cell.Value = ""
        str = start_cell.Value
        tmp = Split(str, "\")
        sFileName = tmp(UBound(tmp))
        sFolder = Mid(str, 1, Len(str) - Len(sFileName) - 1)
        If Len(Dir(sFolder & "\" & sFileName)) > 0 Then
            sShName = start_cell.Offset(, 1).Value
            sRange = start_cell.Offset(, 2).Value
            r = sheet.Range("A" & Rows.Count).End(xlUp).Row
            If r < sheet.Range(oghidulieu_dautien).Row Then
                r = sheet.Range(oghidulieu_dautien).Row
            Else
                r = r + 1
            End If
            Set cell_ = sheet.Range("A" & r)
            Set cell_ = cell_.Resize(sheet.Range(sRange).Rows.Count, sheet.Range(sRange).Columns.Count)
            sLink = "'" & sFolder & "\[" & sFileName & "]" & sShName & "'!" & sRange & ""
            sLink = "=IF(" & sLink & "<>""""," & sLink & ","""")"
            DataLink cell_, sLink, sFileName
        End If
        Set start_cell = start_cell.Offset(1)
    Loop
    
    Application.ScreenUpdating = True
    sheet.Activate
    If Len(sFile) > 0 Then
        sFile = "File link OK:" & vbNewLine & sFile
    Else
        sFile = "Không tìm thâ'y file link."
    End If
    MsgBox "Kêt thúc " & vbNewLine & sFile, vbOKOnly + vbInformation, "Cap nhat OK"

Loi_roi:
    If Err.Number <> 0 Then
        Application.ScreenUpdating = True
        MsgBox "Vui long lien he GPE!", vbCritical + vbOKOnly, "co loi xay ra:"
    End If
    
End Sub
 
Upvote 0
11.jpeg
Mình chạy nó báo lỗi thế này! bạn sửa giúp mình với.
 
Upvote 0
vonguyen3745 đã viết:
View attachment 262703
Mình chạy nó báo lỗi thế này
Nhấp chuột vào đây để mở rộng...
Bạn thiếu đoạn này ở phía trên, code OT gửi lại bài trên chỉ có Sub RunMe thôi:
Mã: 
Option Explicit

Dim sFile  As String
Sub DataLink(ByRef cell_ As Range, ByVal sLink As String, ByVal sFileName As String)
    On Error GoTo Err_
    cell_.FormulaArray = sLink: cell_.Value = cell_.Value
    If Len(sFile) = 0 Then sFile = sFileName Else sFile = sFile & vbNewLine & sFileName
Err_:
End Sub

Toàn bộ code đầy đủ, bạn copy lại tất cả nhé:
Mã: 
Option Explicit

Dim sFile  As String

Sub DataLink(ByRef cell_ As Range, ByVal sLink As String, ByVal sFileName As String)
    On Error GoTo Err_
    cell_.FormulaArray = sLink
    cell_.Value = cell_.Value
    If Len(sFile) = 0 Then sFile = sFileName Else sFile = sFile & vbNewLine & sFileName
Err_:
End Sub

Sub RunMe()

    On Error GoTo Loi_roi:

    Application.ScreenUpdating = False
    Dim sheet As Worksheet, start_cell As Range, cell_ As Range, str As String, tmp, r As Long
    Dim sFolder As String, sFileName As String, sShName As String, sRange As String, sLink As String
    
    Const tenFile_batdau As String = "A2"
    Const oGhidulieu_dautien As String = "A4"
    Const shGhiDuLieu As String = "Sheet2"
    sFile = Empty
    
    Set sheet = ThisWorkbook.Worksheets(shGhiDuLieu)
    sheet.Cells.ClearContents
    Set start_cell = Sheet1.Range(tenFile_batdau)
    
    Do Until start_cell.Value = ""
        str = start_cell.Value
        tmp = Split(str, "\")
        sFileName = tmp(UBound(tmp))
        sFolder = Mid(str, 1, Len(str) - Len(sFileName) - 1)
        If Len(Dir(sFolder & "\" & sFileName)) > 0 Then
            sShName = start_cell.Offset(, 1).Value
            sRange = start_cell.Offset(, 2).Value
            r = sheet.Range("A" & Rows.Count).End(xlUp).Row
            If r < sheet.Range(oGhidulieu_dautien).Row Then
                r = sheet.Range(oGhidulieu_dautien).Row
            Else
                r = r + 1
            End If
            Set cell_ = sheet.Range("A" & r)
            Set cell_ = cell_.Resize(sheet.Range(sRange).Rows.Count, sheet.Range(sRange).Columns.Count)
            sLink = "'" & sFolder & "\[" & sFileName & "]" & sShName & "'!" & sRange & ""
            sLink = "=IF(" & sLink & "<>""""," & sLink & ","""")"
            DataLink cell_, sLink, sFileName
        End If
        Set start_cell = start_cell.Offset(1)
    Loop
    
    Application.ScreenUpdating = True
    sheet.Activate
    If Len(sFile) > 0 Then
        sFile = "File link OK:" & vbNewLine & sFile
    Else
        sFile = "Không tìm thâ'y file link."
    End If
    MsgBox "Kêt thúc " & vbNewLine & sFile, vbOKOnly + vbInformation, "Cap nhat OK"

Loi_roi:
    If Err.Number <> 0 Then
        Application.ScreenUpdating = True
        MsgBox "Vui long lien he GPE!", vbCritical + vbOKOnly, "co loi xay ra:"
    End If
    
End Sub
 
Upvote 0
1.jpeg
2.jpeg
Mình chạy code trên file có đường dẫn thế này nó báo không tìm thấy link, đường dẫn dài quá có ảnh hưởng gì không bạn
 
Upvote 0
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
2
Trả lời
27
Đọc
445
befaint
befaint
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3
Trả lời
54
Đọc
720
ptm0412
ptm0412
K
Tính tổng có điều kiện
Trả lời
3
Đọc
67
HieuCD
H
kyo
  • Suggestion
Bài viết: SAP Scripting – Excel và SAP (P2)
    • Thích
Trả lời
11
Đọc
8K
Tình nghĩa giang hồ
Tình nghĩa giang hồ
H
Kết nối vba với Database host (hiện tại đang làm host web)
Trả lời
4
Đọc
176
ongke0711
ongke0711
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom