Copy dữ liệu từ file excel này sang file excel khác (1 người xem)

[Blad01]

Viết code thể nào để khi bấm vào nút Xuất BCTK sẽ tự động tạo ra một file excel mới thỏa mãn các điều kiện sau:
- Lựa chọn nơi lưu và đặt tên file excel mới.
- Copy giá trị, định dạng (không copy công thức) của Sheet B1.KTÐV-Ð30 và Sheet B2.KTTCÐ-Ð30 của file nguồn vào Sheet B1.KTÐV-Ð30 và Sheet B2.KTTCÐ-Ð30 của file excel mới (dữ liệu của sheet nào copy và sheet đó).
- Dữ liệu vừa được copy tự động căn chỉnh trang in cho vừa chiều ngang của khung giấy A4.
Hoặc có thể làm theo cách 2 (đã ghi rõ trong file đính kèm).
Mong các bạn giúp đỡ.

 

[Blad01]

Có bác nào giúp em với ạ. Em đặt vấn đề khó hiểu hay khó viết code mong các bác hồi âm và tìm cách giúp đỡ. Em phải làm báo cáo thống kê trên 21 sheet, mỗi sheet có công thức liên kết với nhiều sheet khác. Vì vậy mỗi lần báo cáo là phải copy thủ công rất mất thời gian. Mong các bác giúp sức. Cảm ơn nhiều lắm.

 

[Blad01]

Cảm ơn bác hpkhuong nhiều lắm, code chạy rất tốt. Bác có thể giúp em cho thêm đoạn code để delete tất cả các dữ liệu (chữ và hình ảnh) ở trang in thứ 2 trở đi được không, mục đích của em là chỉ dữ lại phần bảng biểu và giá trị của biểu mà thôi.
P/S: B3, B4, B5, B6, B7, B11, B12, B13, B14, B15, B16, B19, B20, B21 căn chỉnh trang in chưa đúng khung in. Mong bác xem và chỉnh code giúp em.

 

[Blad01]

Cảm ơn bạn hpkhuong. vì file của tôi có một số sheet để siêu ẩn lên code không chạy được vì vậy tôi có chỉnh sửa lại chút xíu, nhưng vẫn chưa tối ưu được. Bác nao góp ý và tối ưu giúp tôi đoạn code sau được không ?

Public Sub GPE()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Path As String, oFolder As Object, Arr, Ws As Worksheet, Wb As Workbook
Arr = Array(Sheet3.Name, Sheet5.Name, Sheet7.Name, Sheet9.Name, Sheet11.Name, Sheet13.Name, Sheet15.Name, Sheet17.Name, Sheet19.Name, Sheet21.Name, Sheet23.Name, Sheet25.Name, Sheet27.Name, Sheet29.Name, Sheet31.Name, Sheet33.Name, Sheet35.Name, Sheet37.Name, Sheet39.Name, Sheet41.Name, Sheet42.Name)
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Hay chon thu muc luu file", 0)
If oFolder Is Nothing Then
MsgBox "Chua chon thu muc luu": Exit Sub
End If
Path = oFolder.Items.Item.Path
Sheet3.Visible = True
Sheet5.Visible = True
Sheet7.Visible = True
Sheet9.Visible = True
Sheet11.Visible = True
Sheet13.Visible = True
Sheet15.Visible = True
Sheet17.Visible = True
Sheet19.Visible = True
Sheet21.Visible = True
Sheet23.Visible = True
Sheet25.Visible = True
Sheet27.Visible = True
Sheet29.Visible = True
Sheet31.Visible = True
Sheet33.Visible = True
Sheet35.Visible = True
Sheet37.Visible = True
Sheet39.Visible = True
Sheet41.Visible = True
Sheet42.Visible = True
Sheets(Arr).Copy
Set Wb = ActiveWorkbook
On Error Resume Next
With ActiveSheet
.PageSetup.Zoom = 100
ActiveWindow.View = 2
.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
ActiveWindow.View = 1
End With
Wb.Close True, Path & "\File New.xls"
Sheet3.Visible = 2
Sheet5.Visible = 2
Sheet7.Visible = 2
Sheet9.Visible = 2
Sheet11.Visible = 2
Sheet13.Visible = 2
Sheet15.Visible = 2
Sheet17.Visible = 2
Sheet19.Visible = 2
Sheet21.Visible = 2
Sheet23.Visible = 2
Sheet25.Visible = 2
Sheet27.Visible = 2
Sheet29.Visible = 2
Sheet31.Visible = 2
Sheet33.Visible = 2
Sheet35.Visible = 2
Sheet37.Visible = 2
Sheet39.Visible = 2
Sheet41.Visible = 2
Sheet42.Visible = 2
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[Blad01]

Public Sub GPE()Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Path As String, oFolder As Object, Arr, Ws As Worksheet, Wb As Workbook, J As Long
Arr = Array(Sheet3.Name, Sheet5.Name, Sheet7.Name, Sheet9.Name, Sheet11.Name, Sheet13.Name, Sheet15.Name, Sheet17.Name, Sheet19.Name, Sheet21.Name, Sheet23.Name, Sheet25.Name, Sheet27.Name, Sheet29.Name, Sheet31.Name, Sheet33.Name, Sheet35.Name, Sheet37.Name, Sheet39.Name, Sheet41.Name, Sheet42.Name)
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Hay chon thu muc luu file", 0)
If oFolder Is Nothing Then
MsgBox "Chua chon thu muc luu": Exit Sub
End If
Path = oFolder.Items.Item.Path
For J = 0 To UBound(Arr)
    Sheets(Arr(J)).Visible = -1
Next J
Sheets(Arr).Copy
Set Wb = ActiveWorkbook
For Each Ws In Wb.Worksheets
[COLOR=#ff0000]Ws.Range("A1", Ws.Range("A65000").End(3)).Resize(, 23).Value _[/COLOR]
[COLOR=#ff0000]= Ws.Range("A1", Ws.Range("A65000").End(3)).Resize(, 23).Value[/COLOR]
Ws.PageSetup.PrintArea = Ws.Range("A1", Ws.Range("A65000").End(3)).Resize(, 23).Address
Ws.PageSetup.Orientation = xlLandscape
Ws.PageSetup.PaperSize = xlPaperA4
Next Ws
Wb.Close True, Path & "\File New.xls"
For J = 0 To UBound(Arr)
    Sheets(Arr(J)).Visible = 2
Next J
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Bác hpkhuong xem lại code giúp em với. Khi chưa đặt pass và làm ẩn sheet thì code chạy rất tốt. nhưng đến khi em đặt pass cho các sheet có công thức thì nó báo lỗi tùm lum (báo lỗi phần code em bôi đỏ). Mong bác sửa lại code giúp em với. Cảm ơn bác nhiều lắm. PASS trong file đính kèm là: 1.
Nếu không đặt pass cho các sheet thì code vẫn chạy được nhưng nó lại hiện một bảng thông báo như thế này:

Và em muốn sau khi xuất file thì code có thể tự động mở Pass trên File New.xls có được không ?

 

[Blad01]

Public Sub GPE()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Path As String, oFolder As Object, Arr, Ws As Worksheet, Wb As Workbook
Arr = Array(Sheet3.Name, Sheet5.Name)
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Hay chon thu muc luu file", 0)
If oFolder Is Nothing Then
    MsgBox "Chua chon thu muc luu": Exit Sub
End If
Path = oFolder.Items.Item.Path
Sheet3.Visible = True
Sheet5.Visible = True
Sheets(Arr).Copy
Set Wb = ActiveWorkbook
For Each Ws In Wb.Worksheets
[COLOR=#0000ff][B]    Ws.Unprotect [/B][/COLOR][COLOR=#ff0000][B][SIZE=4]"Pass cua ban"[/SIZE][/B][/COLOR]
    Ws.Range("A1", Ws.Range("A65000").End(3)).Resize(, 23).Value _
    = Ws.Range("A1", Ws.Range("A65000").End(3)).Resize(, 23).Value
    Ws.PageSetup.PrintArea = Ws.Range("A1", Ws.Range("A65000").End(3)).Resize(, 23).Address
    Ws.PageSetup.Orientation = xlLandscape
    Ws.PageSetup.PaperSize = xlPaperA4
[COLOR=#0000ff][B]    Ws.Protect [/B][/COLOR][COLOR=#ff0000][B][SIZE=4]"Pass cua ban"[/SIZE][/B][/COLOR]
Next Ws
    Wb.Close True, Path & "\File New.xlsx"
Sheet3.Visible = 2
Sheet5.Visible = 2
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

nhưng khí xuất file thì nó lại báo như vầy:

bác xem có cách nào khắc phục không. Cảm ơn bác.

 

[Blad01]

Có file ở #8 rồi ạ. Mong bác xem và sửa giúp em với.

 

[Blad01]

Pas là 1 ạ. Em đã sửa và cho file lên rồi. Bác giúp em. Cảm ơn bác. Bác tải lại file ở #8 giúp em với

 

[ttvh]

Option Explicit


Public Sub GPE()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Path As String, oFolder As Object, Arr, Ws As Worksheet, Wb As Workbook
Arr = Array(Sheet3.Name, Sheet5.Name)
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Hay chon thu muc luu file", 0)
If oFolder Is Nothing Then
    MsgBox "Chua chon thu muc luu": Exit Sub
End If
Path = oFolder.Items.Item.Path
Sheets(Arr).Copy
Set Wb = ActiveWorkbook
For Each Ws In Wb.Worksheets
    Ws.Range("A1", Ws.Range("A65000").End(3)).Resize(, 23).Value _
    = Ws.Range("A1", Ws.Range("A65000").End(3)).Resize(, 23).Value
    Ws.PageSetup.PrintArea = Ws.Range("A1", Ws.Range("A65000").End(3)).Resize(, 23).Address
    Ws.PageSetup.Orientation = xlLandscape
    Ws.PageSetup.PaperSize = xlPaperA4
Next Ws
    Wb.Close True, Path & "\File New.xlsx"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Để định dạng lại trang dọc và ấn định lưu vào một Folder cho trước (ví dụ lưu vào ổ E và Folder có tên là PTT) thì Code của anh sửa và thêm chổ nào vậy anh

 

[ttvh]

Ws.PageSetup.Orientation = xlLandscape

Thành

[FONT=Verdana]Ws.PageSetup.Orientation [/FONT][COLOR=#222222][FONT=Verdana]= xlPortrait[/FONT][/COLOR]

Và

Wb.Close True, Path & "\File New.xlsx"

Thành

[FONT=Verdana]Wb.Close True, "E:\PTT\File New.xlsx"[/FONT]

Nhờ Anh coi lại giúp em:
1- Code của anh copy không hết được dữ liệu còn mấy dòng cuối
2- Vẫn phải chọn nơi lưu anh à
3- Em muốn lưu lại tên file do mình đặt trước khi copy vào Folder được không anh

 

[ttvh]

Ws.PageSetup.Orientation = xlLandscape

Thành

[FONT=Verdana]Ws.PageSetup.Orientation [/FONT][COLOR=#222222][FONT=Verdana]= xlPortrait[/FONT][/COLOR]

Và

Wb.Close True, Path & "\File New.xlsx"

Thành

[FONT=Verdana]Wb.Close True, "E:\PTT\File New.xlsx"[/FONT]

Em gửi file anh xem dùm: