Я не могу получить код VBA для сохранения в созданную папку - PullRequest
0 голосов
/ 05 августа 2020

При использовании приведенного ниже кода создается папка, однако экспортируемые листы не сохраняются в папке, они сохраняются только по пути, в котором хранится базовый файл. Я перепробовал все, что мог придумать или найти с помощью поиска, но они не устранили проблему. Любая помощь будет принята с благодарностью.

Sub SplitSheets()       'saves all visible sheets as new xlsx files
    Dim ws As Worksheet, wbNew As Workbook
    Dim sFolderPath As String
    Set wbNew = Application.ThisWorkbook
    sFolderPath = wbNew.Path & "\" & "Import Templates "
    If Dir(sFolderPath) <> "" Then
        'If folder is available
        MsgBox "Folder already exists!", vbInformation, "Import Files"
        Exit Sub
    End If
    'If folder is not available
    MkDir sFolderPath
    For Each ws In ThisWorkbook.Sheets                      'for each worksheet
        If ws.Visible Then                                  'if it's visible:
            Debug.Print "Exporting: " & ws.Name
            ws.Copy '(if no params specified, COPY creates + activates a new wb)
            Set wbNew = Application.ActiveWorkbook          'get new wb object
            wbNew.SaveAs sFolderPath & ws.Name & ".csv", 23 'save new wb
            wbNew.Close                                     'close new wb
            Set wbNew = Nothing                             'cleanup
        End If
    Next ws
    Set ws = Nothing                                        'clean up
End Sub

1 Ответ

2 голосов
/ 05 августа 2020

Перепишите

wbNew.SaveAs sFolderPath & ws.Name & ".csv", 23 

в

wbNew.SaveAs sFolderPath & "\" & ws.Name & ".csv", 23 

и удалите пробел в конце sFolderPath = wbNew.Path & "\" & "Import Templates ".

И вместо выхода из подпрограммы вставьте правильный else заявление, например

If Dir(sFolderPath) <> "" Then
    'If folder is available
    MsgBox "Folder already exists!", vbInformation, "Import Files"
Else
    MkDir sFolderPath
   '  ...
   . insert remaining code
End If
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...