EXCEL VBA

Private Sub GetTestSheets_Click()

 

    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    Dim path As String
    path = ThisWorkbook.path & "\WorkBooks\"
   
    Dim folder
    Set folder = fso.GetFolder(path)
   
    Application.ScreenUpdating = False
   
    Dim output As String
    output = ThisWorkbook.path & "\" & ThisWorkbook.Sheets("GetTestSheets").Range("$E$20").Value

    Dim wb As Workbook
    Set wb = Workbooks.Open(output)
   
    Dim i As Integer
    i = 1
    Dim filename
    Dim sheet As Worksheet
    For Each filename In folder.Files
        Dim tmpWb As Workbook
        Set tmpWb = Workbooks.Open(filename)
        For Each sheet In tmpWb.Sheets
            If sheet.Name <> "目次" Then
                sheet.Copy After:=wb.Sheets(i)
            End If
        Next
        tmpWb.Close (0)
        i = i + 1
    Next

    wb.Save
    wb.Close
       
    Application.ScreenUpdating = True
   
    MsgBox CStr(i - 1) & "文件处理完成。", vbInformation
   
    Set folder = Nothing
    Set fso = Nothing
End Sub

------------------------------

Private Sub CreateSheets_Click()

 

  
    Application.ScreenUpdating = False
   
    Dim inputBook As String
    inputBook = ThisWorkbook.path & "\" & ThisWorkbook.Sheets("CreateSheets").Range("$D$19").Value
   
    Dim templateSheet As String
    templateSheet = ThisWorkbook.Sheets("CreateSheets").Range("$K$19").Value

    Dim outputBook As String
    outputBook = ThisWorkbook.path & "\WorkBooks\" & ThisWorkbook.Sheets("CreateSheets").Range("$D$21").Value
   
    Dim wbIn As Workbook
    Set wbIn = Workbooks.Open(inputBook)
    Dim wbOut As Workbook
    Set wbOut = Workbooks.Add
   
    Dim i As Integer
    i = 3
    wbIn.Sheets("目次").Copy After:=wbOut.Sheets(i)
    i = i + 1
   
    Dim caseNo As String
    Dim j As Integer
    j = 23
    Do
        caseNo = ThisWorkbook.Sheets("CreateSheets").Range("$D$" + CStr(j)).Value
        If caseNo = "" Then
            Exit Do
        End If
        wbIn.Sheets(templateSheet).Copy After:=wbOut.Sheets(i)
        wbOut.Sheets(templateSheet).Select
        wbOut.Sheets(templateSheet).Name = caseNo
        j = j + 1
        i = i + 1
    Loop
   
    wbIn.Close
    wbOut.Sheets("sheet1").Delete
    wbOut.Sheets("sheet2").Delete
    wbOut.Sheets("sheet3").Delete
    wbOut.SaveAs (outputBook)
    wbOut.Close
   
    Application.ScreenUpdating = True
   
    MsgBox CStr(i - 3) & "工作单生成", vbInformation

End Sub