Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Отрезок кода, сохраняющая новый файл в указанную папку
 
#1
10.10.2018 04:54:59
Доброго времени суток.
Есть код, который сплитит файл на n файлов по уникальным значениям указанного столбца.
На данный момент, новые файлы сохраняются в той же папке, где лежит файл с кодом.
Помогите пожалуйста сформировать отрезок кода, который позволил бы сохранять новые файлы в папку
C:\Users\aidyn.khalimbetov\Desktop\Ежедневник\Новая папка\Менеджеры
Код
Sub Zakup()
Application.ScreenUpdating = False

Set shMain = Sheets("Лист1")
lr = shMain.Cells(Rows.Count, "c").End(xlUp).Row
For i = 2 To lr
    If shMain.Range("c" & i) <> shMain.Range("c" & i - 1) Then
    k = 1
        Set wb = Workbooks.Add(1): Set sh = wb.Sheets(1)
        shMain.Rows(1).Copy
        sh.Range("A1").PasteSpecial xlPasteAll
        wb.SaveAs ThisWorkbook.Path & "\" & shMain.Range("c" & i) & " .xlsx", FileFormat:=xlOpenXMLWorkbook
        k = k + 1
        sh.Rows(k) = shMain.Rows(i).Value
        If shMain.Range("c" & i) <> shMain.Range("c" & i + 1) Then wb.Close True
    Else
        k = k + 1
        sh.Rows(k) = shMain.Rows(i).Value
        If shMain.Range("c" & i) <> shMain.Range("c" & i + 1) Then wb.Close True
    End If

Next
End Sub
 
 
 
#2
10.10.2018 05:11:31
adike,Здравствуйте, исходя из того, что ThisWorkbook.Path - возвращает путь, в котором лежит эта книга (из которой запускаете макрос). Как думаете, что необходимо изменить в выложенном вами коде, для сохранения по пути
Цитата
adike написал:
C:\Users\aidyn.khalimbetov\Desktop\Ежедневник\Новая папка\Менеджеры
?
 
 
 
#3
10.10.2018 06:10:42
Должно выглядеть так?
Код
Sub Zakup()Application.ScreenUpdating = False
 
Set shMain = Sheets("Лист1")
lr = shMain.Cells(Rows.Count, "c").End(xlUp).Row
For i = 2 To lr
    If shMain.Range("c" & i) <> shMain.Range("c" & i - 1) Then
    k = 1
        Set wb = Workbooks.Add(1): Set sh = wb.Sheets(1)
        shMain.Rows(1).Copy
        sh.Range("A1").PasteSpecial xlPasteAll
        wb.SaveAs "C:\Users\aidyn.khalimbetov\Desktop\Ежедневник\Новая папка\Менеджеры" & "\" & shMain.Range("c" & i) & " .xlsx", FileFormat:=xlOpenXMLWorkbook
        k = k + 1
        sh.Rows(k) = shMain.Rows(i).Value
        If shMain.Range("c" & i) <> shMain.Range("c" & i + 1) Then wb.Close True
    Else
        k = k + 1
        sh.Rows(k) = shMain.Rows(i).Value
        If shMain.Range("c" & i) <> shMain.Range("c" & i + 1) Then wb.Close True
    End If
 
Next
End Sub
Изменено: adike - 10.10.2018 06:11:01
 
 
 
#4
10.10.2018 06:14:41
Да. Только кусочек этой строки
Код
\Менеджеры" & "\" &
можно записать так:
Код
\Менеджеры\" &
Не стреляйте в тапера - он играет как может.
 
 
 
#5
10.10.2018 06:17:00
Александр П., спасибо за подсказку, работает.
 
 
 
#6
10.10.2018 07:59:02
Я бы добавил переменную типа String и записал так:
Код
Dim iPath$
iPath = "C:\Users\aidyn.khalimbetov\Desktop\Ежедневник\Новая папка\Менеджеры\" 
wb.SaveAs  iPath & shMain.Range("c" & i) & " .xlsx", FileFormat:=xlOpenXMLWorkbook

Для моего глаза при чтении кода это более "удобочитаемо", чем строка скрытая за краем монитора   :D
Изменено: Nordheim - 10.10.2018 08:00:46
"Все гениальное просто, а все простое гениально!!!"
 
 
 
Страницы: 1
Наверх