Sử dụng lệnh Sheets(Array(...)).Copy copy các sheet với số lượng không biết trước (1 người xem)

titanic20072007 · 24/12/14

Chào ae GPE.
Mình đang tạo một macro copy sheet thành tệp mới. Có một vướng mắc thế này:
Nếu copy một số sheet nhất định thì với lệnh Sheets(Array(...,...,...)).Copy mình làm được rồi. Nhưng tình huống của mình mắc là số sheet của tệp cần copy ra tệp mới không biết trước, mình đã sửa lệnh Sheets(Array(...,...,...)).Copy thành: For i =1 to 15 Sheets(Array(Ten(i,1))).Copy với Ten(i,1) là mảng chứa tên các sheet cần copy nhưng vẫn không được.
Nhờ ae giúp đỡ.

Kiều Mạnh · 24/12/14

titanic20072007 đã viết:
Chào ae GPE.
Mình đang tạo một macro copy sheet thành tệp mới. Có một vướng mắc thế này:
Nếu copy một số sheet nhất định thì với lệnh Sheets(Array(...,...,...)).Copy mình làm được rồi. Nhưng tình huống của mình mắc là số sheet của tệp cần copy ra tệp mới không biết trước, mình đã sửa lệnh Sheets(Array(...,...,...)).Copy thành: For i =1 to 15 Sheets(Array(Ten(i,1))).Copy với Ten(i,1) là mảng chứa tên các sheet cần copy nhưng vẫn không được.
Nhờ ae giúp đỡ.

bạn úp file lên ...trình bày vậy triều tượng khó hình dung ra lắm
trả lời theo tiêu đề hên thì trúng

PHP:

 If sh.Name <> "XYZ" Then

titanic20072007 · 24/12/14

Đây là tệp dữ liệu, ae xem giúp mình nhé

ndu96081631 · 24/12/14

titanic20072007 đã viết:
Đây là tệp dữ liệu, ae xem giúp mình nhé

Kiểu vầy nè:

Mã:

Sub Test()
  Dim wks As Worksheet, n As Long
  ReDim arr(1 To 1)
  For Each wks In ThisWorkbook.Worksheets
    If UCase(wks.Name) <> "XEP TKB" Then
      n = n + 1
      ReDim Preserve arr(1 To n)
      arr(n) = wks.Name
    End If
  Next
  Sheets(arr).Copy
  ''[COLOR=#ff0000]Code lưu ActiveWorkbook gì đó tùy bạn[/COLOR]
End Sub

Phần chuyển công thức thành giá trị, tự bạn suy nghĩ nhé

Kiều Mạnh · 24/12/14

titanic20072007 đã viết:
Đây là tệp dữ liệu, ae xem giúp mình nhé

bạn thử 2 code sau xem sao nha...mình đang tập tành code làm thì cũng chạy tốt nhưng khi mở file mới lên thấy Hỏng giống Ai hahahaha...
Tổng hợp vào sheet Xep TKB

PHP:

Sub TongHop_Sheet()
Dim nguon(), kq(1 To 65536, 1 To 25)
Dim sh As Worksheet, i As Long, j As Long, k As Long
For Each sh In Worksheets
   If sh.Name <> "Xep TKB" Then
        nguon = sh.Range("A5", sh.[A65536].End(3)).Resize(, 25).Value
        For i = 1 To UBound(nguon, 1)
            k = k + 1
            For j = 1 To 25
                If nguon(i, 1) <> "" Then
                    kq(k, j) = nguon(i, j)
                End If
           Next
        Next
   End If
Next
[A11].Resize(k, 25) = kq
End Sub

Tổng Hợp vào File mới

PHP:

Sub TongHop_FileMoi()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim nguon(), kq(1 To 65536, 1 To 25)
Dim sh As Worksheet, i As Long, j As Long, k As Long
For Each sh In Worksheets
   If sh.Name <> "Xep TKB" Then
        nguon = sh.Range("A3", sh.[A65536].End(3)).Resize(, 25).Value
        For i = 1 To UBound(nguon, 1)
            k = k + 1
            For j = 1 To 25
                If nguon(i, 1) <> "" Then
                    kq(k, j) = nguon(i, j)
                End If
           Next
        Next
   End If
Next
Workbooks.Add
With ActiveWorkbook
    With ActiveSheet
        .[A1].Resize(k, 25) = kq
    End With
    .SaveAs ThisWorkbook.Path & "\FileMoi"
   .Close True
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

ndu96081631 · 24/12/14

kieu manh đã viết:
bạn thử 2 code sau xem sao nha...mình đang tập tành code làm thì cũng chạy tốt nhưng khi mở file mới lên thấy Hỏng giống Ai hahahaha...

Đúng là.. hổng giống ai thiệt --=0

Chỉ vầy thôi:

Mã:

Sub SaveSheetsToFile()
  Dim wks As Worksheet, wkb As Workbook
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For Each wks In ThisWorkbook.Worksheets
    If UCase(wks.Name) <> "XEP TKB" Then
      If wkb Is Nothing Then
        wks.Copy
        Set wkb = ActiveWorkbook
      Else
        wks.Copy After:=wkb.Worksheets(wkb.Worksheets.Count)
      End If
      With wkb.Worksheets(wks.Name)
        .UsedRange.Value = .UsedRange.Value
      End With
    End If
  Next
  If Not wkb Is Nothing Then
    wkb.SaveAs "D:\NewFile.xls", 56
    wkb.Close True
  End If
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Ngoài ra nếu muốn xóa code sự kiện (worksheet_Change, worksheet_SelectionChange...) trong file mới lại là vấn đề khác

Kiều Mạnh · 24/12/14

ndu96081631 đã viết:

Đúng là.. hổng giống ai thiệt --=0

Chỉ vầy thôi:

Mã:

Sub SaveSheetsToFile()
  Dim wks As Worksheet, wkb As Workbook
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For Each wks In ThisWorkbook.Worksheets
    If UCase(wks.Name) <> "XEP TKB" Then
      If wkb Is Nothing Then
        wks.Copy
        Set wkb = ActiveWorkbook
      Else
        wks.Copy After:=wkb.Worksheets(wkb.Worksheets.Count)
      End If
      With wkb.Worksheets(wks.Name)
        .UsedRange.Value = .UsedRange.Value
      End With
    End If
  Next
  If Not wkb Is Nothing Then
    wkb.SaveAs "D:\NewFile.xls", 56
    wkb.Close True
  End If
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Ngoài ra nếu muốn xóa code sự kiện (worksheet_Change, worksheet_SelectionChange...) trong file mới lại là vấn đề khác

Em đang tập tành code mà Anh
code Anh viết hay thiệt nó tô cả màu Sheet
cảm ơn Anh nhiều

ndu96081631 · 24/12/14

kieu manh đã viết:
code Anh viết hay thiệt nó tô cả màu Sheet

Đâu có tô màu gì đâu. Vì là COPY SHEET nên nguồn thế nào thì đích thế nấy thôi (Move or Copy sheet đấy mà)

titanic20072007 · 25/12/14

Cảm ơn các bạn. Từ những gợi ý trên mình đã chỉnh sửa áp dụng vào giải quyết vấn đề của mình được rồi.

Quang_Hải · 25/12/14

Gặp mình thì bài này mình liều cỡ code này luôn

PHP:

Sub Luu_File()
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Xep TKB").Delete
ThisWorkbook.SaveAs "D:\NewFile.xls", 18
Application.DisplayAlerts = True
End Sub

Kiều Mạnh · 25/12/14

quanghai1969 đã viết:
Gặp mình thì bài này mình liều cỡ code này luôn

PHP:

Sub Luu_File() On Error Resume Next Application.DisplayAlerts = False Sheets("Xep TKB").Delete ThisWorkbook.SaveAs "D:\NewFile.xls", 18 Application.DisplayAlerts = True End Sub

bài này có cách nào undo lại được ko Anh hay xong thoát ko lưu lại thì lại như cũ

Quang_Hải · 25/12/14

kieu manh đã viết:
bài này có cách nào undo lại được ko Anh hay xong thoát ko lưu lại thì lại như cũ

Là sao? File cũ còn nguyên đó, code này tạo ra file mới hòan toàn mà
Thế này sẽ thấy rõ hơn

PHP:

Sub Luu_File()
On Error Resume Next
Application.DisplayAlerts = False
Dim CurWb As String
CurWb = ThisWorkbook.FullName
Sheets("Xep TKB").Delete
With ThisWorkbook
   .SaveAs "D:\NewFile.xls", 18
   Workbooks.Open CurWb
   '.Close
End With
Application.DisplayAlerts = True
End Sub

Kiều Mạnh · 25/12/14

quanghai1969 đã viết:
Là sao? File cũ còn nguyên đó, code này tạo ra file mới hòan toàn mà
Thế này sẽ thấy rõ hơn

PHP:

Sub Luu_File() On Error Resume Next Application.DisplayAlerts = False Dim CurWb As String CurWb = ThisWorkbook.FullName Sheets("Xep TKB").Delete With ThisWorkbook .SaveAs "D:\NewFile.xls", 18 Workbooks.Open CurWb '.Close End With Application.DisplayAlerts = True End Sub

Thì em chạy nó xoá mất Sheets("Xep TKB").Delete
code bài #12 ok tuyệt vời

Quang_Hải · 25/12/14

kieu manh đã viết:
Thì em chạy nó xoá mất Sheets("Xep TKB").Delete

Xem kỹ lại đi, file mới tạo thì làm gì có sheet đó. File cũ vẫn còn nguyên đó.

Kiều Mạnh · 25/12/14

quanghai1969 đã viết:
Xem kỹ lại đi, file mới tạo thì làm gì có sheet đó. File cũ vẫn còn nguyên đó.

Sorry em nhìn lộn sau khi chạy nó đóng file cũ lại mở file mới lên nhìn ko thấy sheet đó nên nghĩ nó Delete mất rồi

Quang_Hải · 25/12/14

kieu manh đã viết:
Sorry em nhìn lộn sau khi chạy nó đóng file cũ lại mở file mới lên nhìn ko thấy sheet đó nên nghĩ nó Delete mất rồi

Nghiên cứu thêm kiểu này luôn đi

PHP:

Sub Luu_File()
On Error Resume Next
Application.DisplayAlerts = False
Dim CurWb As String
CurWb = ThisWorkbook.FullName
Sheets("Xep TKB").Delete
ThisWorkbook.SaveAs "D:\NewFile.xls", 51
Application.Quit
Shell "Excel.exe """ & CurWb & """"
Application.DisplayAlerts = True
End Sub
Sub Auto_Open()
Application.WindowState = xlMaximized
End Sub

Kiều Mạnh · 25/12/14

quanghai1969 đã viết:

Nghiên cứu thêm kiểu này luôn đi

PHP:

Sub Luu_File()
On Error Resume Next
Application.DisplayAlerts = False
Dim CurWb As String
CurWb = ThisWorkbook.FullName
Sheets("Xep TKB").Delete
ThisWorkbook.SaveAs "D:\NewFile.xls", 51
Application.Quit
Shell "Excel.exe """ & CurWb & """"
Application.DisplayAlerts = True
End Sub
Sub Auto_Open()
Application.WindowState = xlMaximized
End Sub

bài #12 anh viết 18 là sao vậy ... em thì biết 50,51,52,56,6 và 36 còn 18 chưa hiểu lắm

Quang_Hải · 25/12/14

kieu manh đã viết:
bài #12 anh viết 18 là sao vậy ... em thì biết 50,51,52,56,6 và 36 còn 18 chưa hiểu lắm

Bài 16 lẽ ra phải viết thế này mới đúng
ThisWorkbook.SaveAs "D:\NewFile.xlsx", 51

18 là lưu file dạng 2003, đuôi file là .xls

Kiều Mạnh · 25/12/14

quanghai1969 đã viết:
Bài 16 lẽ ra phải viết thế này mới đúng
ThisWorkbook.SaveAs "D:\NewFile.xlsx", 51

18 là lưu file dạng 2003, đuôi file là .xls

Vậy là 18 và 56 như nhau
cảm ơn Anh nhiều

Lê Duy Thương · 25/12/14

kieu manh đã viết:
bài #12 anh viết 18 là sao vậy ... em thì biết 50,51,52,56,6 và 36 còn 18 chưa hiểu lắm

trời cái này mà cũng viết code sao ta.
sao không f12--đặt tên file mới-- sau đó xóa sheet TKB la xong. code chi cho mệt . +-+-+-+

Sử dụng lệnh Sheets(Array(...)).Copy copy các sheet với số lượng không biết trước (1 người xem)

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

Thành viên thường trực

I don't program, I beat code into submission!!!

Thành viên thường trực

File đính kèm

Huyền thoại GPE

I don't program, I beat code into submission!!!

File đính kèm

Huyền thoại GPE

I don't program, I beat code into submission!!!

Huyền thoại GPE

Thành viên thường trực

Thành viên gạo cội

I don't program, I beat code into submission!!!

Thành viên gạo cội

I don't program, I beat code into submission!!!

Thành viên gạo cội

I don't program, I beat code into submission!!!

Thành viên gạo cội

I don't program, I beat code into submission!!!

Thành viên gạo cội

I don't program, I beat code into submission!!!

Cạo lấy gì gội (Dịch quá không gội được)

Sinh nhật lần 19 GPE