Вот этот макрос, объединяет несколько файлов в один. По идее мне надо, чтобы имя листа совпадало с именем файла. Как можно этот поправить? [vba]
Код
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", , "Сохранить объединенную книгу")
[/vba]
Вот этот макрос, объединяет несколько файлов в один. По идее мне надо, чтобы имя листа совпадало с именем файла. Как можно этот поправить? [vba]
Код
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", , "Сохранить объединенную книгу")
Так тогда не понятно с именами. Пока написал для первых листов в книгах. Проверяйте, должно работать. [vba]
Код
Sub Объединение()
Dim i As Integer Dim Sel As Workbook, Wb As Workbook
Application.DisplayAlerts = False
MsgBox prompt:="Откройте файлы для объединения" With Application.FileDialog(msoFileDialogOpen) .AllowMultiSelect = True .Show If .SelectedItems.Count > 0 Then Workbooks.Add Set Wb = ActiveWorkbook Do On Error Resume Next ActiveSheet.Delete Loop While Err.Number = 0 For i = 1 To .SelectedItems.Count If InStr(1, .SelectedItems(i), ".xls", vbTextCompare) > 0 Then Workbooks.Open Filename:=.SelectedItems(i) Set Sel = ActiveWorkbook Wb.Activate Worksheets.Add after:=Worksheets(Sheets.Count) On Error Resume Next ActiveSheet.Name = Left(Sel.Name, InStr(1, Sel.Name, ".", vbTextCompare) - 1) If Err.Number <> 0 Then ActiveSheet.Name = Left(Sel.Name, InStr(1, Sel.Name, ".", vbTextCompare) - 1) & i Sel.Worksheets(1).Cells.Copy Destination:=Cells Sel.Close End If Next i If Sheets.Count > 1 Then Worksheets(1).Delete ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Результат.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False End If ActiveWorkbook.Close End If End With
Application.DisplayAlerts = True
End Sub
[/vba]
Так тогда не понятно с именами. Пока написал для первых листов в книгах. Проверяйте, должно работать. [vba]
Код
Sub Объединение()
Dim i As Integer Dim Sel As Workbook, Wb As Workbook
Application.DisplayAlerts = False
MsgBox prompt:="Откройте файлы для объединения" With Application.FileDialog(msoFileDialogOpen) .AllowMultiSelect = True .Show If .SelectedItems.Count > 0 Then Workbooks.Add Set Wb = ActiveWorkbook Do On Error Resume Next ActiveSheet.Delete Loop While Err.Number = 0 For i = 1 To .SelectedItems.Count If InStr(1, .SelectedItems(i), ".xls", vbTextCompare) > 0 Then Workbooks.Open Filename:=.SelectedItems(i) Set Sel = ActiveWorkbook Wb.Activate Worksheets.Add after:=Worksheets(Sheets.Count) On Error Resume Next ActiveSheet.Name = Left(Sel.Name, InStr(1, Sel.Name, ".", vbTextCompare) - 1) If Err.Number <> 0 Then ActiveSheet.Name = Left(Sel.Name, InStr(1, Sel.Name, ".", vbTextCompare) - 1) & i Sel.Worksheets(1).Cells.Copy Destination:=Cells Sel.Close End If Next i If Sheets.Count > 1 Then Worksheets(1).Delete ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Результат.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False End If ActiveWorkbook.Close End If End With
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
