Copy sang các file trong các thư mục khác nhau (1 người xem)

[hongphuong1997]

Cháu nhờ các Bác và Anh chị giúp cháu bài như file đính kèm ạ
Cháu cảm ơn ạ

 

[BuiQuangThuan]

Cháu nhờ các Bác và Anh chị giúp cháu bài như file đính kèm ạ
Cháu cảm ơn ạ

Dữ liệu thấy quen quen nhỉ. cái này hình như chú batman1 từng giúp ai đó.

 

[Hoàng Tuấn 868]

Dữ liệu thấy quen quen nhỉ. cái này hình như chú batman1 từng giúp ai đó.

Giúp đi thôi, đừng dền dứ nữa.

 

[BuiQuangThuan]

Giúp đi thôi, đừng dền dứ nữa.

Hihi. Quá sức anh ạ

 

[Hoàng Tuấn 868]

Hihi. Quá sức anh ạ

Cái này không cần code đi chọn file trong các folder mà nên để bật cửa sổ rồi quét chọn file bằng tay cho đơn giản.

Cháu nhờ các Bác và Anh chị giúp cháu bài như file đính kèm ạ
Cháu cảm ơn ạ

Em gửi cho anh Thuận 2 file đích nữa để anh ấy thử thì chắc là vừa tầm, không sợ "quá sức" nữa.

 

[hongphuong1997]

Cái này không cần code đi chọn file trong các folder mà nên để bật cửa sổ rồi quét chọn file bằng tay cho đơn giản.

Em gửi cho anh Thuận 2 file đích nữa để anh ấy thử thì chắc là vừa tầm, không sợ "quá sức" nữa.

file thì em ghi đường dẫn ở cột "B" rùi đó anh

 

[Hoàng Tuấn 868]

file thì em ghi đường dẫn ở cột "B" rùi đó anh

Chọn tay thì không cần đường dẫn, xem file đích để biết cấu trúc của sheet sẽ dán dữ liệu từ sheet nguồn vào mà.

 

[hongphuong1997]

Chọn tay thì không cần đường dẫn, xem file đích để biết cấu trúc của sheet sẽ dán dữ liệu từ sheet nguồn vào mà.

Anh oi, em không thick chọn tay vì khi đó lại phải ngồi để chờ đợi.
Và mặt khác vì trong ổ cứng có rất nhiều thư mục và nhiều file, nên dễ bị chọn nhầm lắm
Anh viết giúp em với ạ.

 

[HUONGHCKT]

Cháu nhờ các Bác và Anh chị giúp cháu bài như file đính kèm ạ
Cháu cảm ơn ạ

Góp vui. code củ chuối, trúng- trật, hên-sui.
nhấn vào mặt cười để chạy code.

 

[BuiQuangThuan]

file thì em ghi đường dẫn ở cột "B" rùi đó anh

Tự test kết quả lấy. Chưa có bẫy lỗi

Option Explicit
Sub ABC()
    Dim Wb As Workbook, WbM As Workbook
    Dim Ws As Worksheet, sArr(), i&
    Set Wb = ThisWorkbook
    Set Ws = Wb.Sheets("ThongKe")
    sArr = Wb.Sheets("vung").Range("B2:B" & Wb.Sheets("vung").Range("B" & Rows.Count).End(3).Row).Value
    For i = 1 To UBound(sArr)
        Application.Workbooks.Open (sArr(i, 1))
        Set WbM = ActiveWorkbook
        Ws.Range("A6:U100").Copy WbM.Sheets("ThongKe").Range("A6")
        WbM.Close True
    Next
End Sub

 

[Hoàng Tuấn 868]

Anh oi, em không thick chọn tay vì khi đó lại phải ngồi để chờ đợi.
Và mặt khác vì trong ổ cứng có rất nhiều thư mục và nhiều file, nên dễ bị chọn nhầm lắm
Anh viết giúp em với ạ.

Mình có viết thì cũng dài và chạy chậm hơn code của 2 bạn trên nên bạn dùng 2 code này đi nhé.

 

[BuiQuangThuan]

Mình có viết thì cũng dài và chạy chậm hơn code của 2 bạn trên nên bạn dùng 2 code này đi nhé.

Anh cứ viết đi. Em muốn tham khảo mờ. Anh đã viết đâu mà biết nhanh hay chậm hơn.

 

[Hoàng Tuấn 868]

Anh cứ viết đi. Em muốn tham khảo mờ. Anh đã viết đâu mà biết nhanh hay chậm hơn.

Mình viết rồi, đang chạy thử mà giờ chưa chạy xong. Khi nào chạy xong mình đưa lên.

 

[hongphuong1997]

Em cảm ơn tất cả các anh @HUONGHCKT @BuiQuangThuan @Hoàng Tuấn 868 code chạy rất chuẩn các anh oi
à anh @BuiQuangThuan oi, em không biết lỗi ở chỗ nào?
Anh Thêm bẫy lỗi giúp em với ạ
Em cảm ơn các anh

 

[BuiQuangThuan]

Anh Thêm bẫy lỗi giúp em với ạ

Bạn tự viết thêm cái bẫy lỗi đi.
Nếu dữ liệu cột B nhỏ hơn 2 thì lỗi
Nếu đường dẫn tại cột B không tồn tại cũng lỗi

 

[hongphuong1997]

Bạn tự viết thêm cái bẫy lỗi đi.
Nếu dữ liệu cột B nhỏ hơn 2 thì lỗi
Nếu đường dẫn tại cột B không tồn tại cũng lỗi

à, như vậy thì không cần bẫy lỗi cũng được anh oi
Em cảm ơn anh ạ

 

[hongphuong1997]

Tự test kết quả lấy. Chưa có bẫy lỗi

Option Explicit
Sub ABC()
    Dim Wb As Workbook, WbM As Workbook
    Dim Ws As Worksheet, sArr(), i&
    Set Wb = ThisWorkbook
    Set Ws = Wb.Sheets("ThongKe")
    sArr = Wb.Sheets("vung").Range("B2:B" & Wb.Sheets("vung").Range("B" & Rows.Count).End(3).Row).Value
    For i = 1 To UBound(sArr)
        Application.Workbooks.Open (sArr(i, 1))
        Set WbM = ActiveWorkbook
        Ws.Range("A6:U100").Copy WbM.Sheets("ThongKe").Range("A6")
        WbM.Close True
    Next
End Sub

@BuiQuangThuan anh oi!
Em xin mở rộng câu hỏi thêm chút síu anh nhé

 

[BuiQuangThuan]

@BuiQuangThuan anh oi!
Em xin mở rộng câu hỏi thêm chút síu anh nhé

Bạn cứ mở tự nhiên. Mình nghĩ là được. Nhưng sợ lại quá sức với mình. Chờ các anh chị khác coi các anh chị giúp sao.
Mình nghĩ quét tất cả các file trong thư mục bạn đã khai báo và mở từng file lên và làm như trước thôi. Bạn có thể tìm hiểu được mà. Cố lên

 

[hongphuong1997]

Bạn cứ mở tự nhiên. Mình nghĩ là được. Nhưng sợ lại quá sức với mình. Chờ các anh chị khác coi các anh chị giúp sao.
Mình nghĩ quét tất cả các file trong thư mục bạn đã khai báo và mở từng file lên và làm như trước thôi. Bạn có thể tìm hiểu được mà. Cố lên

Hihi..... nói thật sự với anh, em tuy hỏi bài cực nhiều và cũng được rất nhiều anh chị và các Bác siêu cao thủ trên GPE dạy dỗ rất nhiệt tình:
Nhưng thực tình em không thể tự viết code được
Em thật sự đáng buồn về bộ não của em.

 

[BuiQuangThuan]

Hihi..... nói thật sự với anh, em tuy hỏi bài cực nhiều và cũng được rất nhiều anh chị và các Bác siêu cao thủ trên GPE dạy dỗ rất nhiệt tình:
Nhưng thực tình em không thể tự viết code được
Em thật sự đáng buồn về bộ não của em.

Thử tìm hiểu thêm về FileSystemObject
Tại mình biếng. Nên gợi ý cho bạn thế. Bạn chờ được. Mình sẽ làm cho bạn lúc rảnh nha?
Chờ thêm chút nữa. Chắc sẽ có người giúp bạn à

 

[hongphuong1997]

huhu.....buồn quá anh @BuiQuangThuan anh @Hoàng Tuấn 868 oi các anh viết cho em với

 

[BuiQuangThuan]

huhu.....buồn quá anh @BuiQuangThuan anh @Hoàng Tuấn 868 oi các anh viết cho em với

Bạn thua rồi à.....rồi muốn có thành quả lại phải chờ à

 

[Maika8008]

Hihi..... nói thật sự với anh, em tuy hỏi bài cực nhiều và cũng được rất nhiều anh chị và các Bác siêu cao thủ trên GPE dạy dỗ rất nhiệt tình:
Nhưng thực tình em không thể tự viết code được
Em thật sự đáng buồn về bộ não của em.

"các Bác siêu cao thủ trên GPE" -> đừng viết hoa chữ bác bạn nhé! Bác trong lăng mới phải viết hoa còn bác trong GPE mà bị viết hoa thì sợ lắm.

 

[hongphuong1997]

Trước em có sưu tầm được sub() copy này nhưng em không nhớ là của ai?
Code chạy thì rất chuẩn, nhưng mỗi tội là chỉ copy được các file ở trong 1 thư mục (Chắc là sẽ copy được nhiều thư mục ; nhưng em không biết nguyên lý của nó nên không chỉnh sửa được.
Các anh chỉnh sửa cho em với
Em cảm ơn ạ

Public Sub OpenAllFileInFolder2()
tg = Timer
    Dim FSO As Object, ChonFolder As Object, MyFile As Object, Path  As String, TypeF As String
    Dim wk As Workbook
    Dim DefaultRange As String, UserRange As Range, RangePaste As String

DefaultRange = Selection.Address
Set UserRange = Application.InputBox _
        (Prompt:="Select data:", _
        Title:="Copy to all file", _
        Default:=DefaultRange, _
        Type:=8)
RangePaste = UserRange(1, 1).Address
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Path = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FilesyStemObject")
Set ChonFolder = FSO.GetFolder(Path)
For Each MyFile In ChonFolder.Files
    TypeF = FSO.GetExtensionName(MyFile)
    If MyFile.Name <> ThisWorkbook.Name Then
        If TypeF Like "*xls*" Then
            Set wk = Workbooks.Open(MyFile.Path)
            With Sheets("Nguon")
                UserRange.copy .Range(RangePaste)
            
        End With
    End If
    wk.Close True
End If
Next MyFile
Thoat:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
End Sub

 

[snow25]

Trước em có sưu tầm được sub() copy này nhưng em không nhớ là của ai?
Code chạy thì rất chuẩn, nhưng mỗi tội là chỉ copy được các file ở trong 1 thư mục (Chắc là sẽ copy được nhiều thư mục ; nhưng em không biết nguyên lý của nó nên không chỉnh sửa được.
Các anh chỉnh sửa cho em với
Em cảm ơn ạ

Public Sub OpenAllFileInFolder2()
tg = Timer
    Dim FSO As Object, ChonFolder As Object, MyFile As Object, Path  As String, TypeF As String
    Dim wk As Workbook
    Dim DefaultRange As String, UserRange As Range, RangePaste As String

DefaultRange = Selection.Address
Set UserRange = Application.InputBox _
        (Prompt:="Select data:", _
        Title:="Copy to all file", _
        Default:=DefaultRange, _
        Type:=8)
RangePaste = UserRange(1, 1).Address
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Path = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FilesyStemObject")
Set ChonFolder = FSO.GetFolder(Path)
For Each MyFile In ChonFolder.Files
    TypeF = FSO.GetExtensionName(MyFile)
    If MyFile.Name <> ThisWorkbook.Name Then
        If TypeF Like "*xls*" Then
            Set wk = Workbooks.Open(MyFile.Path)
            With Sheets("Nguon")
                UserRange.copy .Range(RangePaste)
           
        End With
    End If
    wk.Close True
End If
Next MyFile
Thoat:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
End Sub

Thêm cái vòng lặp for ở chỗ chọn Folder là được.Nếu dữ liệu được đánh số theo số thứ tự thì có thể dùng được ADO để cập nhập dữ liệu vào.

 

[hongphuong1997]

Thêm cái vòng lặp for ở chỗ chọn Folder là được.Nếu dữ liệu được đánh số theo số thứ tự thì có thể dùng được ADO để cập nhập dữ liệu vào.

Anh oi, anh viết cho em với lâu lắm rùi em chẳng thấy anh viết giúp mọi người gì cả