Code vba xóa sheet có điều kiện

[nhk007dn]

Mình tìm trên GPE thấy nhiều code xóa sheet, nhưng chưa thấy đoạn code mình định nhờ nên lập topic này nhờ các bạn giúp.
Nhờ các bạn giúp 2 đoạn code xóa sheet với điều kiện:
Đoạn 1: Xóa các sheet có tên là các con số, và các sheet có tên là số và chữ (số phải đứng trước chữ) (vd: 1, 2, ..., 22, 23,..., 16-chữ, 17-chữ,...) miễn tìm sheet nào có tên dạng 'số' và 'số-chữ' là xóa.
Đoạn 2: Xóa tất cả các sheet, trừ sheet hiện hành và sheet ẩn (nếu có) với dòng thống báo 'Chắc chưa? Xóa nhầm đừng hối hận'

Mình cảm ơn!

(Các bạn thông cảm, vì cùng code xóa sheet, cùng 1 người hỏi, và cùng 1 thời điểm hỏi nên mình gom 2 đoạn code lại 1 topic này cho tiện.
Nếu vi phạm nội quy thì nhờ các bạn nhắc nhở để mình sửa bài.)

 

[phihndhsp]

Mình tìm trên GPE thấy nhiều code xóa sheet, nhưng chưa thấy đoạn code mình định nhờ nên lập topic này nhờ các bạn giúp.
Nhờ các bạn giúp 2 đoạn code xóa sheet với điều kiện:
Đoạn 1: Xóa các sheet có tên là các con số, và các sheet có tên là số và chữ (số phải đứng trước chữ) (vd: 1, 2, ..., 22, 23,..., 16-chữ, 17-chữ,...) miễn tìm sheet nào có tên dạng 'số' và 'số-chữ' là xóa.
Đoạn 2: Xóa tất cả các sheet, trừ sheet hiện hành và sheet ẩn (nếu có) với dòng thống báo 'Chắc chưa? Xóa nhầm đừng hối hận'

Mình cảm ơn!

(Các bạn thông cảm, vì cùng code xóa sheet, cùng 1 người hỏi, và cùng 1 thời điểm hỏi nên mình gom 2 đoạn code lại 1 topic này cho tiện.
Nếu vi phạm nội quy thì nhờ các bạn nhắc nhở để mình sửa bài.)

Dim sh As Worksheet
đoạn 1 tương ứng yêu cầu 1
'For Each sh In Worksheets
'   If IsNumeric(sh.Name) Or IsNumeric(Left(sh.Name, 1)) Then
'     sh.Cells.Clear
'   End If
'Next


đoạn 2 tương ứng yêu cầu 2
For Each sh In Worksheets
   If sh.Name <> ActiveSheet.Name And sh.Visible = True Then
     sh.Cells.Clear
   End If
Next

xem có đáp ứng yêu cầu của bạn không

 

[nhk007dn]

Dim sh As Worksheet
đoạn 1 tương ứng yêu cầu 1
'For Each sh In Worksheets
'   If IsNumeric(sh.Name) Or IsNumeric(Left(sh.Name, 1)) Then
'     [COLOR=#ff0000]sh.Cells.Clear[/COLOR]
'   End If
'Next


đoạn 2 tương ứng yêu cầu 2
For Each sh In Worksheets
   If sh.Name <> ActiveSheet.Name And sh.Visible = True Then
     [COLOR=#ff0000]sh.Cells.Clear[/COLOR]
   End If
Next

xem có đáp ứng yêu cầu của bạn không

Mình có thể tùy biến dòng màu đỏ cho các yêu cầu tương tự.
Cảm ơn bạn và chúc vui vẻ!

 

[thanhthat]

Dim sh As Worksheet
đoạn 1 tương ứng yêu cầu 1
'For Each sh In Worksheets
'   If IsNumeric(sh.Name) Or IsNumeric(Left(sh.Name, 1)) Then
'     sh.Cells.Clear
'   End If
'Next


đoạn 2 tương ứng yêu cầu 2
For Each sh In Worksheets
   If sh.Name <> ActiveSheet.Name And sh.Visible = True Then
     sh.Cells.Clear
   End If
Next

xem có đáp ứng yêu cầu của bạn không

Mình có một File rất nhiều Sheet, nhờ Bạn code giúp như yêu cầu sau với
1/ Mình muốn lưu file mới có lựa chọn sheet, sẽ lưu file mới có danh sách lựa chọn một vài sheet trên đó, hoặc gồm tất cả các sheet (trừ sheet "Maint" điều khiển, như File kèm).

2/ Tương tự việc xóa sheet cũng vậy, có danh sách lựa chọn xóa một vài sheet hoặc chọn xóa tất cả (trừ xóa sheet Maint).


Cám ơn Bạn nhiếu !!!

 

[befaint]

Mình có một File rất nhiều Sheet, nhờ Bạn code giúp như yêu cầu sau với
1/ Mình muốn lưu file mới có lựa chọn sheet, sẽ lưu file mới có danh sách lựa chọn một vài sheet trên đó, hoặc gồm tất cả các sheet (trừ sheet "Maint" điều khiển, như File kèm).
2/ Tương tự việc xóa sheet cũng vậy, có danh sách lựa chọn xóa một vài sheet hoặc chọn xóa tất cả (trừ xóa sheet Maint).
Cám ơn Bạn nhiếu !!!

Mục 2. Tôi có viết một addins cũng lâu lâu rồi...
Bạn thử dùng xem có được không nhé.

 

[thanhthat]

Mục 2. Tôi có viết một addins cũng lâu lâu rồi...
Bạn thử dùng xem có được không nhé.

Bạn cho mình code luon duoc không, Mình cho vao file luôn.

Cám ơn Bạn !

 

[befaint]

Bạn cho mình code luon duoc không, Mình cho vao file luôn.
Cám ơn Bạn !

Không phải addins là tiện quá rồi sao (ở workbook nào cũng dùng được).
Xem code thì tự vào file mà coi thôi.

 

[thanhthat]

Mục 2. Tôi có viết một addins cũng lâu lâu rồi...
Bạn thử dùng xem có được không nhé.

Nhờ Bạn làm tiếp giúp mình mục 1 với được không.

Cám ơn nhiều.

 

[quanluu]

Mình có một File rất nhiều Sheet, nhờ Bạn code giúp như yêu cầu sau với
1/ Mình muốn lưu file mới có lựa chọn sheet, sẽ lưu file mới có danh sách lựa chọn một vài sheet trên đó, hoặc gồm tất cả các sheet (trừ sheet "Maint" điều khiển, như File kèm).

2/ Tương tự việc xóa sheet cũng vậy, có danh sách lựa chọn xóa một vài sheet hoặc chọn xóa tất cả (trừ xóa sheet Maint).


Cám ơn Bạn nhiếu !!!

Ý 1 thì mình chế biến lại code của bạn xem thế nào:

Sub LuuFile()
    Dim NewName As String
    Dim ws As Worksheet
    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
    "New sheets will be pasted as values, named ranges removed" _
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub


    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        NewName = InputBox("Please Specify the name of your new workbook")
        Sheets("Main").Delete
        For Each ws In ActiveWorkbook.Worksheets        
                ws.Cells.Copy
                ws.Range("A1").PasteSpecial xlPasteValues
        Next ws
       ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & NewName, 52
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

[thanhthat]

Ý 1 thì mình chế biến lại code của bạn xem thế nào:

Sub LuuFile()
    Dim NewName As String
    Dim ws As Worksheet
    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
    "New sheets will be pasted as values, named ranges removed" _
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub


    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        NewName = InputBox("Please Specify the name of your new workbook")
        Sheets("Main").Delete
        For Each ws In ActiveWorkbook.Worksheets        
                ws.Cells.Copy
                ws.Range("A1").PasteSpecial xlPasteValues
        Next ws
       ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & NewName, 52
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Cám ơn bạn !

Bạn có thể dựa trên addins dưới đây và chế biến lại chút ít giúp mình với.

Thanks !

 

[HieuCD]

Mình có một File rất nhiều Sheet, nhờ Bạn code giúp như yêu cầu sau với
1/ Mình muốn lưu file mới có lựa chọn sheet, sẽ lưu file mới có danh sách lựa chọn một vài sheet trên đó, hoặc gồm tất cả các sheet (trừ sheet "Maint" điều khiển, như File kèm).

2/ Tương tự việc xóa sheet cũng vậy, có danh sách lựa chọn xóa một vài sheet hoặc chọn xóa tất cả (trừ xóa sheet Maint).
Cám ơn Bạn nhiếu !!!

mới làm vụ copy

Sub LuuFile()
Dim NewName As String, nm As Name, ws As Worksheet, i As Long, Arr(), tmp, Rng
tmp = MsgBox("Chon Ok neu copy tat ca cac Sheet" & vbCr & _
    "Chon No neu chi Copy cac sheet da khai bao" _
    , vbYesNo, "Copy All sheets to a new workbook")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
NewName = InputBox("Please Specify the name of your new workbook")
If tmp = vbYes Then
    ReDim Arr(1 To ActiveWorkbook.Worksheets.Count - 1)
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> ActiveSheet.Name Then
            i = i + 1
            Arr(i) = ws.Name
        End If
    Next ws
    Sheets(Arr).Copy
Else
    On Error GoTo thoat
    Rng = Range(Range("A2"), Range("A100").End(xlUp))
    Sheets(WorksheetFunction.Transpose(Rng)).Copy
End If
With ActiveWorkbook
    .SaveAs ThisWorkbook.Path & "\" & NewName, 52
    .Close
End With
If Cells(1, 1) = "ZzXxCcVv" Then
thoat:
MsgBox "Ten Sheet sai khong copy duoc!", , "WARNING"
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[HieuCD]

code xóa các Sheet

Sub XoaSheets()
Dim ws As Worksheet, i As Long, tmp, tmp1
tmp = MsgBox("Chon Yes neu Xoa tat ca cac Sheet" & vbCr & _
    "Chon No neu chi Xoa cac sheet duoc chon" _
    , vbYesNo, "WARNING:   Delete All sheets in workbook")


If tmp = vbYes Then tmp1 = MsgBox("Chon Yes neu thuc su Delete tat ca cac Sheet" & vbCr & _
    "Chon No neu huy lenh Delete" _
    , vbYesNo, "WARNING:   Sheets Delete không the khoi phuc!!!")
If tmp1 = vbNo Then Exit Sub


Application.DisplayAlerts = False
Application.ScreenUpdating = False
    For Each ws In Worksheets
        If ws.Name <> ActiveSheet.Name Then
            If tmp = vbYes Then
                ws.Delete
            Else
            tmp1 = MsgBox("Chon Yes neu thuc su Delete Sheet      :  " & ws.Name & vbCr & _
                          "Chon No neu khong muon Delete Sheet:  " & ws.Name _
                , vbYesNo, "WARNING:  Sheets Delete không the khoi phuc!!!")
                If tmp1 = vbYes Then
                    ws.Delete
                End If
            End If
        End If
    Next ws
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[tueyennhi]

Dim sh As Worksheet
đoạn 1 tương ứng yêu cầu 1
'For Each sh In Worksheets
'   If IsNumeric(sh.Name) Or IsNumeric(Left(sh.Name, 1)) Then
'     sh.Cells.Clear
'   End If

'Next
đoạn 2 tương ứng yêu cầu 2
For Each sh In Worksheets
   If sh.Name <> ActiveSheet.Name And sh.Visible = True Then
     sh.Cells.Clear
   End If
Next

xem có đáp ứng yêu cầu của bạn không

Hay quá, đúng cái mình đang cần. Cảm ơn bạn phihndhsp nhiều!

 

[vuvinh7273]

Hay quá, đúng cái mình đang cần. Cảm ơn bạn phihndhsp nhiều!

cái này đúng thứ mình cần, mà mình copy vào không dùng được, giúp mình với 0986567273

 

[Hoàng Tuấn 868]

cái này đúng thứ mình cần, mà mình copy vào không dùng được, giúp mình với 0986567273

Bạn nên gửi file lên và nêu mong muốn cụ thể chứ code đó đâu đã đủ để chạy mà copy về.