Cập nhật dữ liệu vào nhiều files (1 người xem)

[bigbabol89]

Dear các anh chị,

Hàng tháng em phải cập nhật danh sách vào nhiều files khác nhau, danh sách đó thì chỉ có duy nhất. Bất tiện là phải mở từng file 1 lên và copy vào sheet DS ==> Rất mất thời gian.
Em xin mô tả như sau :
- Em sẽ dùng dữ liệu ở file Data copy lần lượt vào từng file ( Test 1, Test 2,...) ở sheet DS.
- Các file Test 1, Test 2,....đều có cấu trúc giống nhau.
- Sheet DS ở các file Test em đều define name để em dùng data validation ở sheet Roster => không cần phải chỉnh lại vùng của data validation.
- Dữ liệu cập nhật hàng tháng có thể nhiều hơn hoặc ít hơn dữ liệu hiện tại ( tóm lại là theo danh sách mới ).
- Em thường hide sheet DS ở các file để mọi người tránh sửa.
Em nhờ các anh giúp làm sao để mình copy nhanh dữ liệu mới vào sheet DS ở các file ( Test 1, Test 2,....) mà không cần mở từng file lên và làm tay.
Em xin cám ơn.

 

[bigbabol89]

Cho code vào File Data -> Chạy code -> Cửa sổ mở ra: Chọn File Test 1, Test 2, .... hoặc nhiều file -> Xong.
Lưu ý: Các File Test 1, 2,.... phải đóng trước khi chạy code.

Public Sub GPE()
Dim Item, Wb As Workbook, Ws As Worksheet, Arr, WsM As Worksheet
Application.ScreenUpdating = False
Set WsM = ThisWorkbook.Sheets("DS")
Arr = WsM.Range("A2", WsM.Range("A" & Rows.Count).End(3)).Resize(, 3).Value
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True 'False
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File", vbInformation, "----Mr.GPE----"
        Exit Sub
    End If
For Each Item In .SelectedItems
    If Left(Item, 1) <> "~" Then
        Application.DisplayAlerts = False
        Application.AskToUpdateLinks = False
            Set Wb = Workbooks.Open(Item)
            Set Ws = Wb.Sheets("DS")
            Ws.Range("A1").CurrentRegion.Offset(1).ClearContents
            Ws.Range("A2").Resize(UBound(Arr), 3).Value = Arr
        Wb.Close True
    End If
Next
End With
MsgBox "Done!"
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Em cám ơn anh, file hoạt động rất tốt.
Tuy nhiên, em hỏi chút, nếu data của em có 6 cột thì sửa như thế nào ạ. Tại khi em làm file ví dụ em chỉ làm có 3 cột thui. Hi hi.

 

[phulien1902]

Bạn tìm trong Code, chỗ nào có số 3 thì thay bằng 6, trừ thằng này End(3) ra nhé.

 

[thoai]

Arr = WsM.Range("A2", WsM.Range("A" & Rows.Count).End(3)).Resize(, 3).Value

thành

Arr = WsM.Range("A2", WsM.Range("A" & Rows.Count).End(3)).Resize(, 6).Value

Và sửa

Ws.Range("A2").Resize(UBound(Arr), 3).Value = Arr

thành

Ws.Range("A2").Resize(UBound(Arr), ubound(Arr,2)).Value = Arr

Arr = WsM.Range("A2", WsM.Range("A" & Rows.Count).End(3)).Resize(, 3).Value

thành

Arr = WsM.Range("A2", WsM.Range("A" & Rows.Count).End(3)).Resize(, 6).Value

Và sửa

Ws.Range("A2").Resize(UBound(Arr), 3).Value = Arr

thành

Ws.Range("A2").Resize(UBound(Arr), ubound(Arr,2)).Value = Arr

Bạn kiểm tra dùm file này sao code k hoạt động. xin cảm ơn

 

[thoai]

Cho code vào File Data -> Chạy code -> Cửa sổ mở ra: Chọn File Test 1, Test 2, .... hoặc nhiều file -> Xong.
Lưu ý: Các File Test 1, 2,.... phải đóng trước khi chạy code.

Public Sub GPE()
Dim Item, Wb As Workbook, Ws As Worksheet, Arr, WsM As Worksheet
Application.ScreenUpdating = False
Set WsM = ThisWorkbook.Sheets("DS")
Arr = WsM.Range("A2", WsM.Range("A" & Rows.Count).End(3)).Resize(, 3).Value
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True 'False
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File", vbInformation, "----Mr.GPE----"
        Exit Sub
    End If
For Each Item In .SelectedItems
    If Left(Item, 1) <> "~" Then
        Application.DisplayAlerts = False
        Application.AskToUpdateLinks = False
            Set Wb = Workbooks.Open(Item)
            Set Ws = Wb.Sheets("DS")
            Ws.Range("A1").CurrentRegion.Offset(1).ClearContents
            Ws.Range("A2").Resize(UBound(Arr), 3).Value = Arr
        Wb.Close True
    End If
Next
End With
MsgBox "Done!"
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

CODE thực hiện copy ngươc từ file data ra file test thì phải, Bác hpKhuong xem có bị nhầm k ah

 

[thoai]

Có vấn đề gì đối với bạn???

Anh cho xin code copy từ nhiều file vào 1 file được không ah