Сборка листов из разных файлов в один

[Vja4eslav]

Доброго всем времени суток!
Имеется макрос, который собирает из разных файлов все содержащиеся в них листы в один файл с именем "Результат". Проблема в том, что названия листов в новом файле он даёт те же, что и в оригиналах + прибавляет через "-" порядковый номер. А надо, чтобы он давал имя самих файлов, откуда он собирает листы + прибавлял через "-" порядковый номер листа.
Т.к. имя листа не может содержать больше 31 символа, то надо брать первые 28 символов названия файла, 1 символ на "-" и 2 символа на порядковый номер.
Может кто- нибудь помочь в этом?
Не знаю, как прикрепить экселевский файл, поэтому просто привожу макрос ниже:

Sub Сбор_листов_в_один_файл()

Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов
Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат

Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
i As Integer, stbar As Boolean

On Error Resume Next 'если указанный путь не существует, обзор начнется с пути по умолчанию
ChDir strStartDir
On Error GoTo 0
With Application 'меньше писанины
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)
If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла
Set wbTarget = Workbooks.Add(template:=xlWorksheet )
.ScreenUpdating = False
stbar = .DisplayStatusBar
.DisplayStatusBar = True
.DisplayAlerts = False

For i = 1 To UBound(arFiles)
.StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)

For Each shSrc In wbSrc.Worksheets
If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
Set shTarget = wbTarget.Sheets.Add(after:=wbTarget .Sheets(wbTarget.Sheets.Count))
shTarget.Name = shSrc.Name & "-" & i
shSrc.Cells.Copy shTarget.Range("A1")
End If
Next
wbSrc.Close False 'закрыть без запроса на сохранение
Next
.ScreenUpdating = True
.DisplayStatusBar = stbar
.StatusBar = False

If wbTarget.Sheets.Count = 1 Then 'не добавлено ни одного листа
MsgBox "В указанных книгах нет непустых листов, сохранять нечего!"
wbTarget.Close False
End
Else
.DisplayAlerts = False
wbTarget.Sheets(1).Delete
.DisplayAlerts = True
End If

On Error Resume Next 'если указанный путь не существует и его не удается создать,
'обзор начнется с последней использованной папки
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
ChDir strSaveDir
On Error GoTo 0
arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")

If VarType(arFiles) = vbBoolean Then 'если не выбрано имя
GoTo save_err
Else
On Error GoTo save_err
wbTarget.SaveAs arFiles
End If
End
save_err:
MsgBox "Книга не сохранена!", vbCritical
End With
End Sub

[Hugo121]

Знакомый код. Первоисточник - Sub FiziK()?
Замените
shTarget.Name = shSrc.Name & "-" & i
на
shTarget.Name = wbSrc.Name & "-" & ii
Ну и конечно для ii нужно свой счётчик сообразить - это домашнее задание
Вроде так.

[Vja4eslav]

Спасибо!

[Vja4eslav]

Вместо
shTarget.Name = wbSrc.Name & "-" & ii
ввёл
shTarget.Name = Left(wbSrc.Name, 28) & "-" & i
А вообще то именно со счётчиком у меня и возникли трудности

[Hugo121]

Да, про 28 забыл...
Ну а счётчик вот - считаем внутри цикла перебора листов, перед циклом обнуляем:

ii=0
For Each shSrc In wbSrc.Worksheets
ii=ii+1


Тут чревато ошибкой, если 28 символов названия файлов будут повторяться. Тогда может действительно лучше i оставить - тогда накладок не будет.

[Vja4eslav]

Спасибо! Всё получилось

[Vja4eslav]

i оставлять было нельзя, т.к. тогда имена листов были бы одинаковы, а Excel этого не позволяет, поэтому нужен был именно Ваш счётчик.
Сейчас всё нормально работает, ещё раз спасибо Вам!

[Hugo121]

С ii могут быть накладки - если вдруг будут разные файлы, одинаковые по начальным 28 символам. Как вариант - дописывать после ii ещё и i, которая меняется на каждом файле.

[Vja4eslav]

Вы абсолютно правы! Извините, что сразу не смог ответить