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

Вход

Регистрация

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

 

= Мир MS Excel/При объединении открыть ту папку, где лежит файл с макросом - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » При объединении открыть ту папку, где лежит файл с макросом (Макросы/Sub)
При объединении открыть ту папку, где лежит файл с макросом
Mark1976 Дата: Четверг, 24.01.2019, 22:49 | Сообщение № 1
Группа: Проверенные
Ранг: Ветеран
Сообщений: 547
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Здравствуйте. Есть макрос, который объединяет файлы. Очень неудобно, что приходится каждый раз после нажатии кнопки искать нужную папку, где находятся файлы для объединения. Мне надо чтобы чтобы при нажатии кнопки "объединить" открывалась та папка, в которой лежит файл с макросом. Заранее спасибо за помощь.
[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]
К сообщению приложен файл: 1354525.xlsm(17.1 Kb)


Сообщение отредактировал Mark1976 - Четверг, 24.01.2019, 22:58
 
Ответить
СообщениеЗдравствуйте. Есть макрос, который объединяет файлы. Очень неудобно, что приходится каждый раз после нажатии кнопки искать нужную папку, где находятся файлы для объединения. Мне надо чтобы чтобы при нажатии кнопки "объединить" открывалась та папка, в которой лежит файл с макросом. Заранее спасибо за помощь.
[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]

Автор - Mark1976
Дата добавления - 24.01.2019 в 22:49
Pelena Дата: Четверг, 24.01.2019, 23:03 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 13622
Репутация: 2998 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
Здравствуйте.
Добавьте строчку
[vba]
Код
.InitialFileName = ThisWorkbook.Path
[/vba]после [vba]
Код
With Application.FileDialog(msoFileDialogOpen)
[/vba]


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеЗдравствуйте.
Добавьте строчку
[vba]
Код
.InitialFileName = ThisWorkbook.Path
[/vba]после [vba]
Код
With Application.FileDialog(msoFileDialogOpen)
[/vba]

Автор - Pelena
Дата добавления - 24.01.2019 в 23:03
krosav4ig Дата: Четверг, 24.01.2019, 23:04 | Сообщение № 3
Группа: Друзья
Ранг: Старожил
Сообщений: 1843
Репутация: 787 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Здравствуйте.
[vba]
Код
Shell "explorer /select,""" & ThisWorkbook.Path & "\!!! Результат.xlsx""", 1
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
СообщениеЗдравствуйте.
[vba]
Код
Shell "explorer /select,""" & ThisWorkbook.Path & "\!!! Результат.xlsx""", 1
[/vba]

Автор - krosav4ig
Дата добавления - 24.01.2019 в 23:04
Mark1976 Дата: Четверг, 24.01.2019, 23:06 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 547
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Спасибо всем за внесение изменение в макрос.
 
Ответить
СообщениеСпасибо всем за внесение изменение в макрос.

Автор - Mark1976
Дата добавления - 24.01.2019 в 23:06
krosav4ig Дата: Четверг, 24.01.2019, 23:15 | Сообщение № 5
Группа: Друзья
Ранг: Старожил
Сообщений: 1843
Репутация: 787 ±
Замечаний: 0% ±

Excel 2007,2010,2013
че-то ляпнул я не дочитав вопрос.
Написанная в моем посте строка при ее размещении в конце кода открывает папку с результатом объединения


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщениече-то ляпнул я не дочитав вопрос.
Написанная в моем посте строка при ее размещении в конце кода открывает папку с результатом объединения

Автор - krosav4ig
Дата добавления - 24.01.2019 в 23:15
Mark1976 Дата: Четверг, 24.01.2019, 23:21 | Сообщение № 6
Группа: Проверенные
Ранг: Ветеран
Сообщений: 547
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
krosav4ig, все работает.


Сообщение отредактировал Mark1976 - Четверг, 24.01.2019, 23:35
 
Ответить
Сообщениеkrosav4ig, все работает.

Автор - Mark1976
Дата добавления - 24.01.2019 в 23:21
Mark1976 Дата: Четверг, 24.01.2019, 23:25 | Сообщение № 7
Группа: Проверенные
Ранг: Ветеран
Сообщений: 547
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Все работает.


Сообщение отредактировал Mark1976 - Четверг, 24.01.2019, 23:31
 
Ответить
СообщениеВсе работает.

Автор - Mark1976
Дата добавления - 24.01.2019 в 23:25
Мир MS Excel » Вопросы и решения » Вопросы по VBA » При объединении открыть ту папку, где лежит файл с макросом (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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