|
|
Регистрация Восстановить пароль |
Регистрация | Задать вопрос |
Заплачу за решение |
Новые сообщения |
Сообщения за день |
Расширенный поиск |
Правила |
Всё прочитано |
|
Опции темы | Поиск в этой теме |
17.08.2011, 10:48 | #1 |
Пользователь
Регистрация: 13.08.2011
Сообщений: 91
|
Сборка листов из разных файлов в один
Доброго всем времени суток!
Имеется макрос, который собирает из разных файлов все содержащиеся в них листы в один файл с именем "Результат". Проблема в том, что названия листов в новом файле он даёт те же, что и в оригиналах + прибавляет через "-" порядковый номер. А надо, чтобы он давал имя самих файлов, откуда он собирает листы + прибавлял через "-" порядковый номер листа. Т.к. имя листа не может содержать больше 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 |
17.08.2011, 11:03 | #2 |
Старожил
Регистрация: 11.05.2010
Сообщений: 5,166
|
Знакомый код. Первоисточник - Sub FiziK()?
Замените shTarget.Name = shSrc.Name & "-" & i на shTarget.Name = wbSrc.Name & "-" & ii Ну и конечно для ii нужно свой счётчик сообразить - это домашнее задание Вроде так.
webmoney: E265281470651 Z422237915069 R418926282008
|
17.08.2011, 11:12 | #3 |
Пользователь
Регистрация: 13.08.2011
Сообщений: 91
|
Спасибо!
|
17.08.2011, 11:22 | #4 |
Пользователь
Регистрация: 13.08.2011
Сообщений: 91
|
Вместо
shTarget.Name = wbSrc.Name & "-" & ii ввёл shTarget.Name = Left(wbSrc.Name, 28) & "-" & i А вообще то именно со счётчиком у меня и возникли трудности |
17.08.2011, 11:25 | #5 |
Старожил
Регистрация: 11.05.2010
Сообщений: 5,166
|
Да, про 28 забыл...
Ну а счётчик вот - считаем внутри цикла перебора листов, перед циклом обнуляем: ii=0 For Each shSrc In wbSrc.Worksheets ii=ii+1 Тут чревато ошибкой, если 28 символов названия файлов будут повторяться. Тогда может действительно лучше i оставить - тогда накладок не будет.
webmoney: E265281470651 Z422237915069 R418926282008
Последний раз редактировалось Hugo121; 17.08.2011 в 11:29. |
17.08.2011, 11:34 | #6 |
Пользователь
Регистрация: 13.08.2011
Сообщений: 91
|
Спасибо! Всё получилось
|
17.08.2011, 11:39 | #7 |
Пользователь
Регистрация: 13.08.2011
Сообщений: 91
|
i оставлять было нельзя, т.к. тогда имена листов были бы одинаковы, а Excel этого не позволяет, поэтому нужен был именно Ваш счётчик.
Сейчас всё нормально работает, ещё раз спасибо Вам! |
17.08.2011, 12:56 | #8 |
Старожил
Регистрация: 11.05.2010
Сообщений: 5,166
|
С ii могут быть накладки - если вдруг будут разные файлы, одинаковые по начальным 28 символам. Как вариант - дописывать после ii ещё и i, которая меняется на каждом файле.
webmoney: E265281470651 Z422237915069 R418926282008
|
17.08.2011, 16:30 | #9 |
Пользователь
Регистрация: 13.08.2011
Сообщений: 91
|
Вы абсолютно правы! Извините, что сразу не смог ответить
|
Похожие темы | ||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
Автоматическое копирование листов с разных файлов в один | Toffifee | Microsoft Office Excel | 0 | 11.05.2011 16:12 |
Сведение данных с разных листов, в один. | ogololobov2009 | Microsoft Office Excel | 2 | 24.01.2011 18:31 |
Сборка нескольких файлов в один | Gamst | Помощь студентам | 4 | 02.06.2010 20:19 |
Задача на копирование ячеек из разных листов на один. | hozpraktik | Microsoft Office Excel | 8 | 28.05.2010 10:00 |
несколько разных строк из разных файлов сформировать в один | Иван123456 | Microsoft Office Excel | 3 | 30.07.2009 17:05 |