增表

ddz79101

老师，我想通过对话框形式新增表.

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下，删除所有工作表（除了第一个，请留意）。。。。
Sub test()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    x = Application.InputBox("请输入需要创建工作表的个数：", "请输入数字,3的倍数", 18, , , , , 1)
    y = x / 3
    ReDim ar(1 To y)
    ReDim br(1 To x)
    For i = 1 To y
        ar(i) = i
    Next
    For i = 1 To 3
        For j = 1 To y
            If i = 1 Then
                n = n + 1
                br(n) = j
            Else
                n = n + 1
                br(n) = j & Chr(63 + i)
            End If
        Next
    Next
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "sheet1" Then
            sh.Delete
        End If
    Next
    For i = 1 To UBound(br)
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = br(i)
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

ddz79101

quqiyuan 发表于 2024-8-24 07:58
参与一下，仅供参考。。。

棒极了！谢谢老师！运行成功！

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, i&, j&, wks As Worksheet, n
   
    n = InputBox("请输入9的整数倍", "", 2)
    If Val(n) = 0 Then Exit Sub Else n = Val(n)
   
    Application.DisplayAlerts = False
    For Each wks In Worksheets
        If wks.Name <> "sheet1" Then wks.Delete
    Next
    ReDim ar(1 To n * 9)
    br = Array("", "A", "B")
    For i = 0 To UBound(br)
        For j = 1 To n * 3
            With Worksheets.Add(after:=Worksheets(Worksheets.Count))
                .Name = j & br(i)
            End With
        Next j
    Next i
   
    Application.DisplayAlerts = True
End Sub

gwjkkkkk

.............

ddz79101

gwjkkkkk 发表于 2024-8-24 11:17
.............

谢谢老师！成功运行！且作为其他代码的一部分也成功。

ddz79101

gwjkkkkk 发表于 2024-8-24 11:17
.............

老师！在吗？我将你的代码放入新建簿中，不能新建表了。可以帮我看看吗？我想新建簿及新增表，另就是所新建德簿存放任意文件夹下。谢谢！

ddz79101

gwjkkkkk 发表于 2024-8-24 11:17
.............

老师！在线吗？

gwjkkkkk

ddz79101 发表于 2024-8-24 16:19
老师！在线吗？

Option Explicit
Sub test()
    Dim ar, br, i&, j&, n, strPath$, strFileName$, wks As Worksheet
   
    n = InputBox("请输入9的整数倍", "", 2)
    If Val(n) = 0 Then Exit Sub Else n = Val(n)
   
    strPath = ThisWorkbook.Path & "\"
    With Application.FileDialog(4)
        .InitialFileName = strPath
        .AllowMultiSelect = True
        If .Show Then
            If Right(.SelectedItems(1), 1) = "\" Then
                strPath = .SelectedItems(1)
            Else
                strPath = .SelectedItems(1) & "\"
            End If
        Else
            Exit Sub
        End If
    End With
   
    Application.DisplayAlerts = False

    ReDim ar(1 To n * 9)
    br = Array("", "A", "B")
    With Workbooks.Add
        strFileName = strPath & "生成"
        For i = 0 To UBound(br)
            For j = 1 To n * 3
                With .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
                    .Name = j & br(i)
                End With
            Next j
        Next i
        For Each wks In .Worksheets
            If wks.Name Like "*Sheet*" Then wks.Delete
        Next
        .SaveAs strFileName
        .Close
    End With
   
    Application.DisplayAlerts = True
End Sub