Страницы: 1
RSS
Копирование листа в другую книгу без расширения, или изменения макроса
 
Уважаемые знатоки экселя!
Я когда то скопировал макрос Николая Павлова и Дмитрия Щербакова (для меня - пророки экселя) по копированию листов в новую книгу.
Код
Sub CombineWorkbooks()

    Dim FilesToOpen

    Dim x As Integer

    Application.ScreenUpdating = False 
'отключаем обновление экрана для скорости

     

    'вызываем диалог выбора файлов для импорта

    FilesToOpen = Application.GetOpenFilename _

      (FileFilter:="Excel files (*.xls), *.xls", _

      MultiSelect:=True,
Title:="Files to Merge")

 

    If TypeName(FilesToOpen) =
"Boolean" Then

        MsgBox "Не выбрано ни
одного файла!"

        Exit Sub

    End If

    'проходим по всем выбранным файлам

    x = 1

    While x <= UBound(FilesToOpen)

        Set importWB =
Workbooks.Open(Filename:=FilesToOpen(x))

        Sheets(1).Copy
After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

       
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = importWB.Name

        importWB.Close
'savechanges:=False

        x = x + 1

    Wend

    Application.ScreenUpdating = True

End Sub 

В отличии от других макросов, листы копируются с именами и расширениями файлов. Как чайник по экселю хотел изменить макрос так, что бы листы копировались бы без расширения. Но, увы, старания не привели к успеху. Наверно, профессионалам экселя это смешно, но хотел сказать, что в пути знания наверно и Вы начали быть "духом" ..))). Кто то может помочь хотя бы намекнуть, что делать?
 
Например:
Код
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Left(importWB.Name, Len(importWB.Name) - InStrRev(importWB.Name, ".", -1, 1) + 1)
 
Код
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Left(importWB.Name, InStr(importWB.Name, ".") - 1)
Изменено: VideoAlex - 07.07.2018 12:17:00
 
Я бы еще добавил обрезку до 31 символа. Еще лучше все это в функцию обернуть:
Код
Function GetShName(ByVal sName As String)
    Dim lp As Long, s As String
    s = sName
    If InStr(1, sName, ".", 1) Then
        lp = InStrRev(sName, ".")
        If lp > 0 Then
            s = Mid(sName, lp, 4)
            If s Like ".xl*" Then
                s = Mid(sName, 1, lp - 1)
            End If
        End If
    End If
    GetShName = Mid(s, 1, 31)
End Function

и потом только вызывать:
Код
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = GetShName(importWB.Name)

Конечно, не мешало бы проверить еще и на совпадение имен(чтобы не получилось так, что лист с таким именем уже есть).
Изменено: Дмитрий(The_Prist) Щербаков - 08.07.2018 11:43:26
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Огромное спасибо, ребята!
Дмитрий, Вашему знанию - поклон !!!
Изменено: maryo - 09.07.2018 15:57:17
Страницы: 1
Наверх