code VBA lấy dữ liệu từ nhiều file vào 1 file

Chia sẻ bởi:hands

★★★★★

‹ Tự động điền dữ liệu từ ô... Hỏi về cách ghi dữ liệu sang... ›

Quảng cáo

em xin cảm ơn ạ

Xin nhờ các anh chị trên diễn dàn giúp em,

Mỗi tuần lễ, trên văn phòng chính sẽ xuất 1 file báo cáo xuống (mỗi file khoảng 7.000 dòng), cuối tháng em phải lấy nội dung của từng file ( chỉ lấy 9 cột trong mỗi file : cột K , cột R đến cột Y) rồi dán hết vào file tổng hợp .

Kết quả cuối cùng là lấy nội dung cột K, cột R, S , T , U ….. Y (lấy từ hàng thứ 6 trở xuống đến hết nội dung file), dán kết quả này vào sheet KDN của file tổng hợp, (bắt đầu dán ở ô C3), chuyển các số liệu thành number.
tiếp tục hiện lên bảng hỏi mình xem có muốn lấy nữa không, nếu không thì thoát là xong, nếu có thì hỏi đường dẫn đến file kế tiếp, rồi làm như trên, chú ý là dán tiếp theo kể từ hàng cuối cùng của lần dán thứ 1 nhé.
Làm xong hỏi tiếp xem có muốn lấy dữ liệu nữa không….. cứ như thế đến khi nào mình chọn không thì thoát.

Hiện nay em đang phải copy bằng tay từng cột trong từng file rất thủ công (dùng công thức thì không biết trước file 1 kết thúc ở hàng nào để tiếp theo là file thứ 2, với lại, mỗi file report là 1 tên khác nhau (vd : KDN_21_10_2019 2019 09 23 , KDN_21_10_2019 2019 10 14…. )

Có cách nào để tạo 1 nút cập nhật, khi nhấn vào thì nó sẽ hỏi file 1 ở đâu, chỉ đường dẫn đến thì nó chỉ copy đúng nội dung của 9 cột mà mình chỉ định trước , dán qua file tổng hợp, xong hỏi mình có muốn copy tiếp hay không, chọn có thì tiếp tục hỏi đường dẫn file 2 rồi copy và dán nối tiếp sau phần nội dung của file thứ nhất, chọn không thì thoát ra.

Lưu ý : số liệu lấy ra chuyển qua file tổng hợp phải được định dạng lại là number vì còn phải dùng để tính toán (file report gốc không được định dạng là number nên hiện nay mỗi khi copy qua em lại phải dùng hàm value để chuyển nó lại là number)

em xin cảm ơn ạ

Bạn thử.

Sub tonghop()
     Application.ScreenUpdating = False
     Application.AskToUpdateLinks = False
     Application.DisplayAlerts = False
     Dim cn As Object, sqlStr As String, i As Long, lr As Long, k, rst As Object, Pro As String, ext As String, arr(), a As Long
     Dim sarr, j As Long, b As Long
     Set cn = CreateObject("ADODB.Connection")
     Set rst = CreateObject("ADODB.recordset")
     With Application.FileDialog(msoFileDialogFilePicker)
quaylai:
       If Not .Show = -1 Then GoTo xong
       k = .SelectedItems(1)
       Pro = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
       ext = ";Extended Properties=""Excel 12.0;HDR=No;IMEX= 1"";"
       cn.Open (Pro & k & ext)
       sqlStr = "Select f1,f8,f9,f10,f11,f12,f13,f14,f15 from [Page 1$K6:Y50000] where f1 is not null"
       'Debug.Print sqlStr
       sarr = cn.Execute(sqlStr).GetRows
       arr = quydoi(sarr)
       cn.Close
       lr = Sheets("KDN").Range("C" & Rows.Count).End(xlUp).Row + 1
       Sheets("KDN").Range("C" & lr).Resize(UBound(arr), UBound(arr, 2)).Value = arr
       If MsgBox("Ban co lay them nua khong", vbYesNo) = vbYes Then
          GoTo quaylai
       Else
          GoTo xong
       End If
    End With
xong:
     Application.ScreenUpdating = True
     Application.AskToUpdateLinks = True
     Application.DisplayAlerts = True
End Sub
Function quydoi(ByVal arr)
    Dim kq, i As Long, j As Long
    ReDim kq(1 To UBound(arr, 2) + 1, 1 To UBound(arr) + 1)
    For i = 0 To UBound(arr, 2)
        For j = 0 To UBound(arr, 1)
            kq(i + 1, j + 1) = arr(j, i)
        Next j
    Next i
    quydoi = kq
End Function