Sub Books2Sheets()
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    Dim newwb As Workbook
    Set newwb = Workbooks.Add
    
    With fd
        If .Show = -1 Then
            Dim vrtSelectedItem As Variant
            Dim i As Integer
            i = 1
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            
            For Each vrtSelectedItem In .SelectedItems
                Dim tempwb As Workbook
                Set tempwb = Workbooks.Open(vrtSelectedItem)
                
                Dim sheetName As String
                sheetName = GetValidSheetName(VBA.Replace(tempwb.name, ".xlsx", ""))
                
                tempwb.Worksheets(1).Copy Before:=newwb.Worksheets(i)
                newwb.Worksheets(i).name = sheetName
                
                tempwb.Close SaveChanges:=False
                i = i + 1
            Next vrtSelectedItem
        End If
    End With
    
    Set fd = Nothing
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "合并完成", vbInformation + vbOKCancel, "逗号Office技巧"
End Sub

Function GetValidSheetName(name As String) As String
    Dim maxLength As Integer
    maxLength = 31
    
    name = Replace(name, "[", "")
    name = Replace(name, "]", "")
    name = Replace(name, "：", "")
    
    Dim dotPosition As Integer
    dotPosition = InStrRev(name, ".")
    
    If dotPosition > 0 Then
        name = Left(name, dotPosition - 1)
    End If
    
    If Len(name) > maxLength Then
        name = Left(name, maxLength)
    End If
    
    GetValidSheetName = name
End Function