Lấy danh sách các sheet đưa vào mảng (1 người xem)

[nth09061985]

Công việc của em cần copy các sheet trong 1 Fille Excel (copy tất cả các sheet trừ sheet "TongHop") sang 1 File Excel mới và em có sưu tầm được code của anh QuangHai1969 trên GPE:

Sub CopySheetToNewWB()
Dim sh As Worksheet, NewFileName, Name As Name
With ThisWorkbook.Sheets([B][COLOR=#ff0000]Array("A", "B", "C", "D")[/COLOR][/B])
   .Copy
   With ActiveWorkbook
      For Each sh In .Worksheets
         sh.UsedRange.Value = sh.UsedRange.Value
      Next
      NewFileName = Application.GetSaveAsFilename
      .SaveAs NewFileName & "xlsx"
      .Close
   End With
End With
End Sub

Code hoạt động rất tốt tuy nhiên nếu chỉ có 1 vài sheet thì không sao tuy nhiên nếu số lượng Sheet trong File của Em rất nhiều và số lượng Sheet này thay đổi không biết trước.
Em muốn hỏi các anh chị: Có cách nào có lấy tên tất cả các sheet "A", "B","C","D",....(trừ Sheet "TongHop") như trong File đính kem để không phải nhập tay như dòng tô màu đỏ kia không ạ!
P/S: Trong File đính kèm này em muốn lấy được tên 4 sheet là "A", "B","C","D" .

 

[ndu96081631]

Em muốn hỏi các anh chị: Có cách nào có lấy tên tất cả các sheet "A", "B","C","D",....(trừ Sheet "TongHop") như trong File đính kem để không phải nhập tay như dòng tô màu đỏ kia không ạ!
P/S: Trong File đính kèm này em muốn lấy được tên 4 sheet là "A", "B","C","D" .

Copy toàn bộ, trừ sheet TongHop? Vậy ta làm đơn giản hơn: Copy toàn bộ, kể cả sheet TongHop rồi xóa sheet TongHop đi là xong

Sub CopySheetToNewWB()
  Dim sh As Worksheet, NewFileName, Name As Name
  With [COLOR=#ff0000]ThisWorkbook.Sheets[/COLOR]
    .Copy
    With ActiveWorkbook
      [COLOR=#0000cd]Application.DisplayAlerts = False[/COLOR][COLOR=#ff0000]
      .Sheets("TongHop").Delete
      [/COLOR][COLOR=#0000cd]Application.DisplayAlerts = True[/COLOR]
      For Each sh In .Worksheets
''...........................
''............................
End Sub

Chỗ màu đỏ là sửa lại
Cặp code màu xanh lồng trước và sau code xóa sheet TongHop là để Excel khỏi hỏi xóa luôn

 

[nth09061985]

Copy toàn bộ, trừ sheet TongHop? Vậy ta làm đơn giản hơn: Copy toàn bộ, kể cả sheet TongHop rồi xóa sheet TongHop đi là xong

Sub CopySheetToNewWB()
  Dim sh As Worksheet, NewFileName, Name As Name
  With [COLOR=#ff0000]ThisWorkbook.Sheets[/COLOR]
    .Copy
    With ActiveWorkbook
      [COLOR=#0000cd]Application.DisplayAlerts = False[/COLOR][COLOR=#ff0000]
      .Sheets("TongHop").Delete
      [/COLOR][COLOR=#0000cd]Application.DisplayAlerts = True[/COLOR]
      For Each sh In .Worksheets
''...........................
''............................
End Sub

Chỗ màu đỏ là sửa lại
Cặp code màu xanh lồng trước và sau code xóa sheet TongHop là để Excel khỏi hỏi xóa luôn

Cảm ơn bạn! Đúng là 1 cách xử lí rất thông minh ạ! Tôi sẽ áp dụng. Tuy nhiên cho hỏi thêm nếu vẫn cố tình làm theo phương án 1 thì có giải quyết được không bạn?

 

[nghiabaclieu]

Copy toàn bộ, trừ sheet TongHop? Vậy ta làm đơn giản hơn: Copy toàn bộ, kể cả sheet TongHop rồi xóa sheet TongHop đi là xong

Sub CopySheetToNewWB()
  Dim sh As Worksheet, NewFileName, Name As Name
  With [COLOR=#ff0000]ThisWorkbook.Sheets[/COLOR]
    .Copy
    With ActiveWorkbook
      [COLOR=#0000cd]Application.DisplayAlerts = False[/COLOR][COLOR=#ff0000]
      .Sheets("TongHop").Delete
      [/COLOR][COLOR=#0000cd]Application.DisplayAlerts = True[/COLOR]
      For Each sh In .Worksheets
''...........................
''............................
End Sub

Chỗ màu đỏ là sửa lại
Cặp code màu xanh lồng trước và sau code xóa sheet TongHop là để Excel khỏi hỏi xóa luôn

dạ cho em hỏi code này copy và paste được luôn hay có chỉnh gì ko ạ, sao em copy vào bị lỗi ạ

 

[huuthang_bd]

Cảm ơn bạn! Đúng là 1 cách xử lí rất thông minh ạ! Tôi sẽ áp dụng. Tuy nhiên cho hỏi thêm nếu vẫn cố tình làm theo phương án 1 thì có giải quyết được không bạn?

Vậy bạn thử làm vầy

Sub CopySheetToNewWB()
Dim ShName() As String, i As Long, j As Long
ReDim ShName(1 To ThisWorkbook.Sheets.Count)
For i = 1 To ThisWorkbook.Sheets.Count
    If ThisWorkbook.Sheets(i).Name = "TongHop" Then
        ReDim Preserve ShName(1 To ThisWorkbook.Sheets.Count - 1)
    Else
        j = j + 1
        ShName(j) = ThisWorkbook.Sheets(i).Name
    End If
Next
ThisWorkbook.Sheets(ShName).Copy
'...............................
End Sub

Góp ý chút: Chỉ có mỗi một lệnh Copy thì đưa vào cấu trúc With làm gì cho rối thêm?

 

[nth09061985]

Vậy bạn thử làm vầy

Sub CopySheetToNewWB()
Dim ShName() As String, i As Long, j As Long
ReDim ShName(1 To ThisWorkbook.Sheets.Count)
For i = 1 To ThisWorkbook.Sheets.Count
    If ThisWorkbook.Sheets(i).Name = "TongHop" Then
        ReDim Preserve ShName(1 To ThisWorkbook.Sheets.Count - 1)
    Else
        j = j + 1
        ShName(j) = ThisWorkbook.Sheets(i).Name
    End If
Next
ThisWorkbook.Sheets(ShName).Copy
'...............................
End Sub

Góp ý chút: Chỉ có mỗi một lệnh Copy thì đưa vào cấu trúc With làm gì cho rối thêm?

Cảm ơn bạn nhé! Mình test thử kết quả chính xác rồi!