从第一个工作表开始每隔一个工作表删除一次（所以 1、3、5 ...）

Question

我目前正在使用来自 Kutools 的 VBA 代码，它可以让我将我所有的作品sheet 组合成一个组合的“大师”sheet。然而，每一个相关的工作sheet 之前都有一个不相关的工作应该和不能合并。所以我需要先删除 worksheets 1,3,5... 才能使代码正常工作。

或者，忽略那些工作sheet并仅组合所有其他工作sheet (2,4,6...) 也可以。

这是我使用的 VBA 代码：

    Sub Combine()
'UpdateByKutools20151029
    Dim i As Integer
    Dim xTCount As Variant
    Dim xWs As Worksheet
    On Error Resume Next
LInput:
    xTCount = Application.InputBox("The number of title rows", "", "1")
    If TypeName(xTCount) = "Boolean" Then Exit Sub
    If Not IsNumeric(xTCount) Then
        MsgBox "Only can enter number", , "Kutools for Excel"
        GoTo LInput
    End If
    Set xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))
    xWs.Name = "Combined"
    Worksheets(2).Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")
    For i = 2 To Worksheets.Count
        Worksheets(i).Range("A1").CurrentRegion.Offset(CInt(xTCount), 0).Copy _
               Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1, 1)
    Next
End Sub

感谢您的帮助！

Answer 1

如果您只想删除工作表 1,3,5,...

Dim i As Long
Dim LastWk As Integer
'delete odds worksheets

'first we must check if last worksheet is odd or even
LastWk = Worksheets.Count
LastWk = IIf(Application.WorksheetFunction.IsOdd(LastWk), LastWk, LastWk - 1)

For i = LastWk To 1 Step -2
    Application.DisplayAlerts = False
    Worksheets(i).Delete
    Application.DisplayAlerts = True
Next i

你只需要一个循环但使用可选参数Step（每次循环都会更改数量计数器。如果未指定，步骤默认为一个。）

我们向后迭代，因此删除工作表时索引不会改变

For...Next statement

Answer 2

通常当我们从集合中删除项目时，我们会向后迭代以避免项目从其原始位置移动。在这里，我创建了一个包含所有奇数工作表名称的数组，并使用它一次删除它们。

Sub ReplaceOddWorksheets()
    Const Delimiter As String = "\"
    Dim SheetNames As String
    Dim n As Long
    For n = 1 To Worksheets.Count Step 2
        SheetNames = SheetNames & Delimiter & Worksheets(n).Name
    Next
    SheetNames = Mid(SheetNames, 2)
    
    Application.DisplayAlerts = False
    Sheets(Split(SheetNames, Delimiter)).Delete
    Application.DisplayAlerts = True
End Sub

Answer 3

从每个其他工作表复制数据

Sub CombineEveryOtherWorksheet()

    Const wsName As String = "Combined"
    
    Dim hrCount As Variant
    Dim msg As Long
    
    Do
        hrCount = Application.InputBox("The number of title rows", "", "1")
        If TypeName(hrCount) = "Boolean" Then Exit Sub
        If IsNumeric(hrCount) Then Exit Do
        msg = MsgBox("Please enter a whole number.", _
            vbExclamation + vbYesNo, "Try again?")
        If msg = vbNo Then Exit Sub
    Loop
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim dws As Worksheet
    On Error Resume Next
        Set dws = wb.Worksheets(wsName)
    On Error GoTo 0
    If Not dws Is Nothing Then
        msg = MsgBox("The worksheet already exists. " _
            & "Do you want to delete it?", vbExclamation + vbYesNo, "Continue?")
        If msg = vbNo Then
            Exit Sub
        Else
            Application.DisplayAlerts = False
            dws.Delete
            Application.DisplayAlerts = True
        End If
    End If
    wb.Worksheets(1).Copy Before:=wb.Sheets(1)
    Set dws = wb.Worksheets(1)
    dws.Name = wsName
    
    Dim wsCount As Long: wsCount = wb.Worksheets.Count
    If wsCount < 4 Then Exit Sub
    
    Dim dfCell As Range
    Set dfCell = dws.Cells(dws.Range("A1").CurrentRegion.Rows.Count + 1, "A")
    
    Dim srg As Range
    Dim n As Long
    
    For n = 4 To wb.Worksheets.Count Step 2
        With wb.Worksheets(n).Range("A1").CurrentRegion
            Set srg = .Resize(.Rows.Count - hrCount).Offset(hrCount)
        End With
        srg.Copy dfCell
        Set dfCell = dfCell.Offset(srg.Rows.Count)
    Next n

    MsgBox "Master worksheet created.", vbInformation
   
End Sub

从第一个工作表开始每隔一个工作表删除一次（所以 1、3、5 ...）

Delete every second worksheet starting with the first (so 1, 3, 5...)

excel

vba

worksheet-function

从每个其他工作表复制数据