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

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
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

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

G
Xin Code xóa Module.
Trả lời
11
Đọc
441
GCQ
G
H
  • Question Question
Tô đậm tiêu đề cho cho các sheet
Trả lời
4
Đọc
125
hieu998
H
GPE-Trợ Lý
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
    • Thích
Trả lời
1
Đọc
876
GPE-Trợ Lý
GPE-Trợ Lý
Z
TRỢ GIÚP K SORT ĐƯỢC THỨ TỰ NGÀY THÁNG NĂM TRONG EXCEL
Trả lời
2
Đọc
69
Duy Tùng 9x
Duy Tùng 9x
H
Tách file nguồn thành nhiều file dựa vào điều kiện (2 người xem)
Trả lời
5
Đọc
121
LePhatHuy
LePhatHuy
D
Nhờ trợ giúp xác định thứ tự của các từ và cụm từ trong 1 chuỗi văn bản. (1 người xem)
Trả lời
9
Đọc
195
duongbabao90
D
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
7
Đọc
327
fujishima
F
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
49
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
tính thể tích bồn dầu hình trụ elip nằm ngang
Trả lời
10
Đọc
47K
pvkiem
P
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
18
Đọc
393
tle2003
T
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
14
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ
Trả lời
17
Đọc
499
VetMini
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
348
Đọc
31K
ongke0711
ongke0711
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ
2
Trả lời
23
Đọc
764
nguyendang95
N
G
Tách công thức ra khỏi chuỗi và tính kết quả?
2
Trả lời
26
Đọc
2K
thuytrangbp28
T
thlpro
Cách lập Công thức tính số ngày nghỉ AL, ưu tiên tính 2024 trước rồi mới tính 2025
Trả lời
8
Đọc
216
bebo021999
B
N
Hàm tăng số đếm theo điều kiện
Trả lời
4
Đọc
128
bebo021999
B
M
Xin giúp đỡ làm công thức điều kiện
    • Yêu thích
Trả lời
3
Đọc
178
tayGa
T
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính
    • Thích
Trả lời
2
Đọc
266
nguyendang95
N
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
5
Đọc
223
DeTong
D
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
Back
Top Bottom