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

Вход

Регистрация

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

 

= Мир MS Excel/Вставка данных из нескольких листов одной книги - Мир MS Excel

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

Excel 2016
Добрый день. Просьба помочь в следующем вопросе.
Имеется макрос, который работает с кучей листов в одном документе и копирует их в каталог где размещены другие документы, в имени которых встречается название листа.
Изначально макрос работал как часы, пока в коде был жестко прописать путь, куда копировать данные.
На данный момент возникала потребность открывать и сохранять данные в разных каталогах, каждый раз лезть в код и править адрес руками не хочется.
Сейчас код был доработан и в принципе все работает, только сохраняет все документы на один каталог выше конечного.
[vba]
Код

Sub Vizit_otchet()
  
    On Error Resume Next
    Dim folder$, coll As Collection
    Dim StartFolder As String
   StartFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop")
  Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
  With oFD
        .Title = "Выбрать папку"
        .ButtonName = "Выбрать папку"
        .Filters.Clear
        .InitialFileName = StartFolder
        .InitialView = msoFileDialogViewLargeIcons
        If oFD.Show = 0 Then Exit Sub
        folder$ = .SelectedItems(1) 'считываем путь к папке
    End With
     
    If Dir(folder$, vbDirectory) = "" Then
        MsgBox "Не найдена папка «" & folder$ & "»", vbCritical, "Нет папки"
        Exit Sub
    End If
   
    Set coll = FilenamesCollection(folder$, "*.xlsx") ' расширение файлов
      
    If coll.Count = 0 Then
        MsgBox "В папке «" & Split(folder$, "\")(UBound(Split(folder$, "\")) - 1) & "» нет ни одного подходящего файла!", _
               vbCritical, "Что-то пошло не так!!!"
        Exit Sub
        Else
            If 7 = MsgBox("Обнаружено: " & coll.Count & " файлов" & vbCr & "Продолжить?", 292, "Подтвердите изменение документов") Then Exit Sub
    End If
Na = ("Отчеты по визитам ")
Dim wb As Workbook
Set wb = ActiveWorkbook
Select Case Left(wb.Name, 2)
    Case "ФК": d = "ФК"
    Case "СГ": d = "СГА"
    Case "НА": d = "НАС"
    Case "ТД": d = "ТД"
End Select
If d = 0 Then MsgBox ("Это какая-то левая книга.."): Exit Sub
Application.DisplayAlerts = False
pth = Na
For Each sh In wb.Worksheets
    fpth = pth & sh.Name & ".xlsx"
    If Dir(fpth) = "" Then
        Workbooks.Add
        sh.Copy before:=ActiveSheet
        ActiveSheet.Name = "Данные" & d
        ActiveWorkbook.SaveAs Filename:=fpth
    Else
        Workbooks.Open Filename:=fpth
        Worksheets(d).Name = d & "temp"
        sh.Copy before:=ActiveSheet
        ActiveSheet.Name = d
        Worksheets(d & "temp").Delete
    End If
    ActiveWorkbook.Close 1
Next
Application.DisplayAlerts = True
End Sub
[/vba]
Помогите пожалуйста с решением проблемы, чтоб все сохранялось куда надо.


Ку-ку мой мальчик..
 
Ответить
СообщениеДобрый день. Просьба помочь в следующем вопросе.
Имеется макрос, который работает с кучей листов в одном документе и копирует их в каталог где размещены другие документы, в имени которых встречается название листа.
Изначально макрос работал как часы, пока в коде был жестко прописать путь, куда копировать данные.
На данный момент возникала потребность открывать и сохранять данные в разных каталогах, каждый раз лезть в код и править адрес руками не хочется.
Сейчас код был доработан и в принципе все работает, только сохраняет все документы на один каталог выше конечного.
[vba]
Код

Sub Vizit_otchet()
  
    On Error Resume Next
    Dim folder$, coll As Collection
    Dim StartFolder As String
   StartFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop")
  Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
  With oFD
        .Title = "Выбрать папку"
        .ButtonName = "Выбрать папку"
        .Filters.Clear
        .InitialFileName = StartFolder
        .InitialView = msoFileDialogViewLargeIcons
        If oFD.Show = 0 Then Exit Sub
        folder$ = .SelectedItems(1) 'считываем путь к папке
    End With
     
    If Dir(folder$, vbDirectory) = "" Then
        MsgBox "Не найдена папка «" & folder$ & "»", vbCritical, "Нет папки"
        Exit Sub
    End If
   
    Set coll = FilenamesCollection(folder$, "*.xlsx") ' расширение файлов
      
    If coll.Count = 0 Then
        MsgBox "В папке «" & Split(folder$, "\")(UBound(Split(folder$, "\")) - 1) & "» нет ни одного подходящего файла!", _
               vbCritical, "Что-то пошло не так!!!"
        Exit Sub
        Else
            If 7 = MsgBox("Обнаружено: " & coll.Count & " файлов" & vbCr & "Продолжить?", 292, "Подтвердите изменение документов") Then Exit Sub
    End If
Na = ("Отчеты по визитам ")
Dim wb As Workbook
Set wb = ActiveWorkbook
Select Case Left(wb.Name, 2)
    Case "ФК": d = "ФК"
    Case "СГ": d = "СГА"
    Case "НА": d = "НАС"
    Case "ТД": d = "ТД"
End Select
If d = 0 Then MsgBox ("Это какая-то левая книга.."): Exit Sub
Application.DisplayAlerts = False
pth = Na
For Each sh In wb.Worksheets
    fpth = pth & sh.Name & ".xlsx"
    If Dir(fpth) = "" Then
        Workbooks.Add
        sh.Copy before:=ActiveSheet
        ActiveSheet.Name = "Данные" & d
        ActiveWorkbook.SaveAs Filename:=fpth
    Else
        Workbooks.Open Filename:=fpth
        Worksheets(d).Name = d & "temp"
        sh.Copy before:=ActiveSheet
        ActiveSheet.Name = d
        Worksheets(d & "temp").Delete
    End If
    ActiveWorkbook.Close 1
Next
Application.DisplayAlerts = True
End Sub
[/vba]
Помогите пожалуйста с решением проблемы, чтоб все сохранялось куда надо.

Автор - S_K_
Дата добавления - 10.07.2018 в 17:10
InExSu Дата: Вторник, 10.07.2018, 21:03 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 423
Репутация: 51 ±
Замечаний: 20% ±

Excel 2010
Привет!
попробуйте заменить строку
[vba]
Код
pth = Na
[/vba]
на
[vba]
Код
pth = folder$ & "\" & Na
[/vba]


На сохранение второго закона термодинамики: яндекс.кошелёк 410012113235839
 
Ответить
СообщениеПривет!
попробуйте заменить строку
[vba]
Код
pth = Na
[/vba]
на
[vba]
Код
pth = folder$ & "\" & Na
[/vba]

Автор - InExSu
Дата добавления - 10.07.2018 в 21:03
S_K_ Дата: Среда, 11.07.2018, 12:17 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Спасибо большое.
Теперь все работает как надо!


Ку-ку мой мальчик..
 
Ответить
СообщениеСпасибо большое.
Теперь все работает как надо!

Автор - S_K_
Дата добавления - 11.07.2018 в 12:17
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Вставка данных из нескольких листов одной книги (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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