Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Название файла и название листа - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Название файла и название листа (Макросы/Sub)
Название файла и название листа
Mark1976 Дата: Суббота, 23.04.2016, 13:56 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 418
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Вот этот макрос, объединяет несколько файлов в один. По идее мне надо, чтобы имя листа совпадало с именем файла. Как можно этот поправить?
[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]


Сообщение отредактировал Mark1976 - Суббота, 23.04.2016, 14:22
 
Ответить
СообщениеВот этот макрос, объединяет несколько файлов в один. По идее мне надо, чтобы имя листа совпадало с именем файла. Как можно этот поправить?
[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]

Автор - Mark1976
Дата добавления - 23.04.2016 в 13:56
StoTisteg Дата: Суббота, 23.04.2016, 14:26 | Сообщение № 2
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

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


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеМарк, Вы палите из пушки по воробьям. У Вас, насколько я понимаю, в каждом файте по одному листу, поэтому всё гораздо проще. Сейчас сделаю.

Автор - StoTisteg
Дата добавления - 23.04.2016 в 14:26
Mark1976 Дата: Суббота, 23.04.2016, 14:34 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 418
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Ага. Спасибо. В файле может быть несколько листов.
 
Ответить
СообщениеАга. Спасибо. В файле может быть несколько листов.

Автор - Mark1976
Дата добавления - 23.04.2016 в 14:34
Mark1976 Дата: Суббота, 23.04.2016, 14:34 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 418
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Но я буду оставлять один лист.
 
Ответить
СообщениеНо я буду оставлять один лист.

Автор - Mark1976
Дата добавления - 23.04.2016 в 14:34
StoTisteg Дата: Суббота, 23.04.2016, 15:11 | Сообщение № 5
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

Excel 2010
Так тогда не понятно с именами. Пока написал для первых листов в книгах. Проверяйте, должно работать.
[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]
К сообщению приложен файл: FileMerger.xlsm(14Kb)


Проверь всё. ThisWorkbook.Save. On Error Resume Next.

Сообщение отредактировал StoTisteg - Суббота, 23.04.2016, 15:12
 
Ответить
СообщениеТак тогда не понятно с именами. Пока написал для первых листов в книгах. Проверяйте, должно работать.
[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]

Автор - StoTisteg
Дата добавления - 23.04.2016 в 15:11
Mark1976 Дата: Суббота, 23.04.2016, 16:19 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 418
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Ок. Спасибо. Вечером гляну. Сейчас на днюхе у тещи.
 
Ответить
СообщениеОк. Спасибо. Вечером гляну. Сейчас на днюхе у тещи.

Автор - Mark1976
Дата добавления - 23.04.2016 в 16:19
Mark1976 Дата: Суббота, 23.04.2016, 20:27 | Сообщение № 7
Группа: Проверенные
Ранг: Обитатель
Сообщений: 418
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
StoTisteg, Вы как всегда на высоте. Все отлично. Спасибо огромное !!!!!!!!!
 
Ответить
СообщениеStoTisteg, Вы как всегда на высоте. Все отлично. Спасибо огромное !!!!!!!!!

Автор - Mark1976
Дата добавления - 23.04.2016 в 20:27
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Название файла и название листа (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2017 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!