Cần Giúp đỡ code copy nội dung từ file mau đến file baocao cùng lúc nhiều sheets (1 người xem)

mritdng · 19/9/16

Cần Giúp đỡ

Cảm ơn diễn đàn và các thầy cô đã giúp đỡ.

quanluu · 19/9/16

mritdng đã viết:
Do nhu cầu công việc phải thay đổi nội dung form liên tục.mỗi lần thay đổi mình phải copy + dán rất tốn thời gian.nay lên nhờ các thầy và các bạn giúp đỡ

Mình có gởi lên đây 2 file "mẫu" chứa nội dung cần copy và file "báo cáo" có nhiều sheet là file mình cần copy dữ lieu vào
mong các thầy và các bạn giúp mình làm sao khi cần thay đổi mình chỉ can điền nội dung vào file mẫu sau đó chạy code và tìm đến file báo cáo thì nội dung sẽ tự động copy vào file Banbáo cáo ạ.mình cảm ơn

Bạn chỉ cần copy cho sheet đầu thui, các sheet khác bạn dùng công thức để lấy dữ liệu từ sheet đầu, cần gì phải code bạn.

mritdng · 19/9/16

quanluu1989 đã viết:
Bạn chỉ cần copy cho sheet đầu thui, các sheet khác bạn dùng công thức để lấy dữ liệu từ sheet đầu, cần gì phải code bạn.

Đúng rồi bạn.Vấn đề ở đây là rất nhiều file bạn ơi.1 tháng mình phải sửa gần 300 file như vậy để in ra lưu cho 2 công ty khác nhau.copy dán gần nửa ngày mới xong đấy bạn.

quanluu · 19/9/16

mritdng đã viết:
Đúng rồi bạn.Vấn đề ở đây là rất nhiều file bạn ơi.1 tháng mình phải sửa gần 300 file như vậy để in ra lưu cho 2 công ty khác nhau.copy dán gần nửa ngày mới xong đấy bạn.

Thế vấn đề của bạn là copy/ paste cho nhiều file? chứ ko phải copy/paste cho 1 file có nhiều sheets ah? hay là nhiều file với nhiều sheets?

mritdng · 19/9/16

quanluu1989 đã viết:
Thế vấn đề của bạn là copy/ paste cho nhiều file? chứ ko phải copy/paste cho 1 file có nhiều sheets ah? hay là nhiều file với nhiều sheets?

Đúng rồi bạn.file baocao mình có đưa lên chỉ là 1 file để copy/paste từ file mẫu qua.vì phải gởi cho 2 cty nên phải thay đổi nội dung.mình phải copy/paste gần 300 file như vậy.

quanluu · 19/9/16

mritdng đã viết:
Đúng rồi bạn.file baocao mình có đưa lên chỉ là 1 file để copy/paste từ file mẫu qua.vì phải gởi cho 2 cty nên phải thay đổi nội dung.mình phải copy/paste gần 300 file như vậy.

Bạn thử code sau
Bạn để file mẫu và các file khác cùng folder

Mã:

Sub copy()
Dim FSO As Object, wbmain As Workbook, wb As Workbook, fileitem As Object
Application.ScreenUpdating = False
    wbmain = ThisWorkbook
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each fileitem In FSO.GetFolder(wbmain.Path).Files
        If fileitem.Name <> wbmain.Name And Left(fileitem.Name, 1) <> "~" Then
            Set wb = Workbooks.Open(fileitem.Path)
            wbmain.ActiveSheet.Range("A1:C2").copy wb.ActiveSheet.Range("A1")
            wbmain.ActiveSheet.Range("A24:C27").copy wb.ActiveSheet.Range("A24")
            wb.Close False
        End If
    Next
    Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

mritdng · 19/9/16

quanluu1989 đã viết:

Bạn thử code sau
Bạn để file mẫu và các file khác cùng folder

Mã:

Sub copy()
Dim FSO As Object, wbmain As Workbook, wb As Workbook, fileitem As Object
Application.ScreenUpdating = False
    wbmain = ThisWorkbook
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each fileitem In FSO.GetFolder(wbmain.Path).Files
        If fileitem.Name <> wbmain.Name And Left(fileitem.Name, 1) <> "~" Then
            Set wb = Workbooks.Open(fileitem.Path)
            wbmain.ActiveSheet.Range("A1:C2").copy wb.ActiveSheet.Range("A1")
            wbmain.ActiveSheet.Range("A24:C27").copy wb.ActiveSheet.Range("A24")
            wb.Close False
        End If
    Next
    Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

code báo lỗi bạn ơi.xem lại giúp mình với,cảm ơn bạn

quanluu · 19/9/16

mritdng đã viết:
code báo lỗi bạn ơi.xem lại giúp mình với,cảm ơn bạn

Sorry bạn, mình chưa có thời gian test code
bạn thử code này, chỗ bôi đỏ là chỗ mình update

Mã:

Sub copy()
Dim FSO As Object, wbmain As Workbook, wb As Workbook, fileitem As Object
Application.ScreenUpdating = False
   [COLOR=#ff0000] Set[/COLOR] wbmain = ThisWorkbook
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each fileitem In FSO.GetFolder(wbmain.Path).Files
        If fileitem.Name <> wbmain.Name And Left(fileitem.Name, 1) <> "~" Then
            Set wb = Workbooks.Open(fileitem.Path)
            wbmain.ActiveSheet.Range("A1:C2").copy wb.ActiveSheet.Range("A1")
            wbmain.ActiveSheet.Range("A24:C27").copy wb.ActiveSheet.Range("A24")
            wb.Close [COLOR=#ff0000]True[/COLOR]
        End If
    Next
    Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

mritdng · 19/9/16

quanluu1989 đã viết:

Sorry bạn, mình chưa có thời gian test code
bạn thử code này, chỗ bôi đỏ là chỗ mình update

Mã:

Sub copy()
Dim FSO As Object, wbmain As Workbook, wb As Workbook, fileitem As Object
Application.ScreenUpdating = False
   [COLOR=#ff0000] Set[/COLOR] wbmain = ThisWorkbook
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each fileitem In FSO.GetFolder(wbmain.Path).Files
        If fileitem.Name <> wbmain.Name And Left(fileitem.Name, 1) <> "~" Then
            Set wb = Workbooks.Open(fileitem.Path)
            wbmain.ActiveSheet.Range("A1:C2").copy wb.ActiveSheet.Range("A1")
            wbmain.ActiveSheet.Range("A24:C27").copy wb.ActiveSheet.Range("A24")
            wb.Close [COLOR=#ff0000]True[/COLOR]
        End If
    Next
    Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

vẫn lỗi bạn.mình chạy code nó ra cái bảng để chọn lưu nhưng lại có tập tin mở rộng .txt và tắt thì nó lại hiện ra cái bảng đó lại

quanluu · 19/9/16

mritdng đã viết:
vẫn lỗi bạn.mình chạy code nó ra cái bảng để chọn lưu nhưng lại có tập tin mở rộng .txt và tắt thì nó lại hiện ra cái bảng đó lại

Mình test trên 2 file bạn gửi đính kềm ko có vấn đề gì cả, bạn nên đưa file chuẩn để test
Mình cũng nghi là trong folder của bạn còn những loại file khác: txt,pdf... nó cũng có thể là nguyên nhân.
Bạn test lại code

Mã:

Sub copy()
Dim FSO As Object, wbmain As Workbook, wb As Workbook, fileitem As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Set wbmain = ThisWorkbook
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each fileitem In FSO.GetFolder(wbmain.Path).Files
        If fileitem.Name <> wbmain.Name And Left(fileitem.Name, 1) <> "~" And Right(fileitem.Name, 4) = "xlsx" Then
            Set wb = Workbooks.Open(fileitem.Path)
            wbmain.ActiveSheet.Range("A1:C2").copy wb.ActiveSheet.Range("A1")
            wbmain.ActiveSheet.Range("A24:C27").copy wb.ActiveSheet.Range("A24")
            wb.Close True
        End If
    Next
    Set FSO = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

mritdng · 19/9/16

Lúc nãy mình để thử 2 file ngoài Desktop chung với nhưng file khác.bây giờ mình bỏ riêng 2 file vô 1 thư mục chạy code sau cùng thì ok không báo lỗi nhưng chỉ copy vào đc mỗi sheets đầu tiên của file baocao thôi bạn,còn những sheet còn lại thì không thấy nó copy qua.thanks bạn nhờ bạn giúp

mritdng · 19/9/16

cảm ơn bạn đã hổ trợ mình nhé

quanluu · 19/9/16

mritdng đã viết:
mình copy thử file mẫu và 5 file báo cáo bỏ vào 1 thư mục và chạy code trên file mẫu thì nó chỉ copy qua đc ở sheet đầu tiên của 5 file,còn nhưng sheet còn lại chưa copy đc bạn ơi

Ủa, mình tưởng 1 file 1 sheet. hic
Vậy thế này coi

Mã:

Sub copy()
Dim FSO As Object, wb As Workbook, fileitem As Object, arr, arr1, sh As Worksheet, wbmain As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    arr = Range("A1:C2").Value
    arr1 = Range("A24:C27").Value
    Set wbmain = ThisWorkbook
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each fileitem In FSO.GetFolder(wbmain.Path).Files
        If fileitem.Name <> wbmain.Name And Left(fileitem.Name, 1) <> "~" And Right(fileitem.Name, 4) = "xlsx" Then
            Set wb = Workbooks.Open(fileitem.Path)
            With wb
                For Each sh In .Sheets
                    sh.Range("A1").Resize(2, 3) = arr
                    sh.Range("A24").Resize(4, 3) = arr1
                Next
                .Close True
            End With
        End If
    Next
    Set FSO = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

mritdng · 20/9/16

quanluu1989 đã viết:

Ủa, mình tưởng 1 file 1 sheet. hic
Vậy thế này coi

Mã:

Sub copy()
Dim FSO As Object, wb As Workbook, fileitem As Object, arr, arr1, sh As Worksheet, wbmain As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    arr = Range("A1:C2").Value
    arr1 = Range("A24:C27").Value
    Set wbmain = ThisWorkbook
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each fileitem In FSO.GetFolder(wbmain.Path).Files
        If fileitem.Name <> wbmain.Name And Left(fileitem.Name, 1) <> "~" And Right(fileitem.Name, 4) = "xlsx" Then
            Set wb = Workbooks.Open(fileitem.Path)
            With wb
                For Each sh In .Sheets
                    sh.Range("A1").Resize(2, 3) = arr
                    sh.Range("A24").Resize(4, 3) = arr1
                Next
                .Close True
            End With
        End If
    Next
    Set FSO = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

code này chạy ok bạn.cảm ơn bạn nhé

Cần Giúp đỡ code copy nội dung từ file mau đến file baocao cùng lúc nhiều sheets (1 người xem)

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

mritdng

Thành viên mới

quanluu

Thành viên gắn bó

mritdng

Thành viên mới

quanluu

Thành viên gắn bó

mritdng

Thành viên mới

quanluu

Thành viên gắn bó

mritdng

Thành viên mới

quanluu

Thành viên gắn bó

mritdng

Thành viên mới

quanluu

Thành viên gắn bó

mritdng

Thành viên mới

mritdng

Thành viên mới

quanluu

Thành viên gắn bó

mritdng

Thành viên mới

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

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