Добрый день. Просьба помочь в следующем вопросе. Имеется макрос, который работает с кучей листов в одном документе и копирует их в каталог где размещены другие документы, в имени которых встречается название листа. Изначально макрос работал как часы, пока в коде был жестко прописать путь, куда копировать данные. На данный момент возникала потребность открывать и сохранять данные в разных каталогах, каждый раз лезть в код и править адрес руками не хочется. Сейчас код был доработан и в принципе все работает, только сохраняет все документы на один каталог выше конечного. [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_