Макрос создать папку если ее нет excel

Добрий день!

Нужна помощь в написании макроса
1. нужно макросом проверить наличие по пути D:workARCHIN папки yyyy(год, например 2015), если нет такой папки то создать, затем в папке yyyy проверить наличие папки mm.yy(номер месяца.год, например , 07.15) если нет такой папки то создать, затем в папке mm.yy создать папки, например папка 1, папка 2, папка 3

в результате

должно получится например,  D:workARCHIN20157.15папка 1

2. нужно макросом проверить для каждой папки например, папка 1, папка 2, папка 3(ети папки находятся  по пути D:tempODобработание файлиОтчети ) наличие
папки yyyy(год, например 2015), если нет такой папки то создать, затем
проверить в папке yyyy наличие папки mm(номер месяца например , 07) если нет такой папки то создать

в результате

должно получится например, D:tempODобработание файлиОтчетипапка 120157

I have a list of items in a sheet like so:

My code goes through each row and groups the supplier and copies some information into a work book for each supplier. In this scenario there are 2 unique suppliers, so 2 workbooks will be created. This works.

Next I want to save each workbook in a specific folder path. If the folder path does not exist then it should be created.

Here’s the piece of code for this bit:

'Check directort and save
                Path = "G:BUYINGFood Specials4. Food Promotions(1) PLANNING(1) ProjectsPromo Announcements" & .Range("H" & i) & "KW " & .Range("A" & i) & ""
                
                If Dir(Path, vbDirectory) = "" Then
                Shell ("cmd /c mkdir """ & Path & """")
                End If
                
                wbTemplate.SaveCopyAs Filename:=Path & file & " - " & file3 & " (" & file2 & ").xlsx"

For some reason, both workbooks are saved if the directory exists, but only one workbook is saved if the directory doesn’t exist and has to be created.

Full Code:

Sub Create()
'On Error GoTo Message
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
    Dim WbMaster As Workbook
    Dim wbTemplate As Workbook
    Dim wStemplaTE As Worksheet
    Dim i As Long
    Dim Lastrow As Long
    Dim rngToChk As Range
    Dim rngToFill As Range
    Dim rngToFill2 As Range
    Dim rngToFill3 As Range
    Dim rngToFill4 As Range
    Dim rngToFill5 As Range
    Dim rngToFill6 As Range
    Dim rngToFill7 As Range
    Dim rngToFill8 As Range
    Dim rngToFill9 As Range
    Dim rngToFil20 As Range
    Dim CompName As String
    Dim WkNum As Integer
    Dim WkNum2 As Integer
    Dim WkNum3 As Integer
    Dim WkNum4 As Integer
    
    Dim FilePath1 As String
    Dim TreatedCompanies As String
    Dim FirstAddress As String
    '''Reference workbooks and worksheet
    Set WbMaster = ThisWorkbook
    
    WkNum = Left(ThisWorkbook.Worksheets(1).Range("C5").Value, (InStr(1, ThisWorkbook.Worksheets(1).Range("C5").Value, " - ")) - 1)
    WkNum2 = Trim(WkNum)
    WkNum3 = Right(ThisWorkbook.Worksheets(1).Range("C5").Value, (InStr(1, ThisWorkbook.Worksheets(1).Range("C5").Value, " - ")) - 1)
    WkNum4 = Trim(WkNum3)
    
    '''Loop through Master Sheet to get wk numbers and supplier names
    With WbMaster.Sheets(1)
    Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    
    For i = 11 To Lastrow
    
    Set rngToChk = .Range("A" & i)
    MyWeek = rngToChk.Value
    CompName = rngToChk.Offset(0, 5).Value
    
    'Check Criteria Is Met
    If MyWeek >= WkNum2 And MyWeek <= WkNum4 And InStr(1, TreatedCompanies, CompName) Or CompName = vbNullString Then
    
    
    
    
    'Start Creation
        '''Company already treated, not doing it again
            Else
                '''Open a new template
                On Error Resume Next
                Set wbTemplate = Workbooks.Open("G:BUYINGFood Specials4. Food Promotions(1) PLANNING(1) ProjectsPromo AnnouncementsAnnouncement Template.xlsx")
                Set wStemplaTE = wbTemplate.Sheets(1)

                '''Set Company Name to Template
                wStemplaTE.Range("C13").Value = CompName
                   
                
                '''Add it to to the list of treated companies
                TreatedCompanies = TreatedCompanies & "/" & CompName
                '''Define the 1st cell to fill on the template
                Set rngToFill = wStemplaTE.Range("A31")
                
                
                'Remove uneeded announcement rows
                'wStemplaTE.Range("A31:A40").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True


                
                'On Error GoTo Message21
                'Create Folder Directory
                file = AlphaNumericOnly(.Range("G" & i))
                file2 = AlphaNumericOnly(.Range("C" & i))
                file3 = AlphaNumericOnly(.Range("B" & i))
                
                'Check directort and save
                Path = "G:BUYINGFood Specials4. Food Promotions(1) PLANNING(1) ProjectsPromo Announcements" & .Range("H" & i) & "KW " & .Range("A" & i) & ""
                
                If Dir(Path, vbDirectory) = "" Then
                Shell ("cmd /c mkdir """ & Path & """")
                End If
                
                wbTemplate.SaveCopyAs Filename:=Path & file & " - " & file3 & " (" & file2 & ").xlsx"
                
                wbTemplate.Close False
            
            
            End If
                 

    Next i
    
    End With

                            
End Sub



Function AlphaNumericOnly(strSource As String) As String
    Dim i As Integer
    Dim strResult As String

    For i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
                strResult = strResult & Mid(strSource, i, 1)
        End Select
    Next
    AlphaNumericOnly = strResult
End Function

Никто и не говорил про необходимость проверять возникновение ошибок…
Я в подобных случаях использую примерно такие конструкции:

1
2
3
4
5
6
7
8
9

Private Sub Workbook_Open()
    On Error Resume Next: Err.Clear
    Путь = "C:Tempимя папки"
    If Len(Dir(Путь)) = 0 And True Or Day(Date) = 28 Then MkDir (Путь)
    If Err Then MsgBox "Не удалось создать папку", vbCritical: Exit Sub
    ThisWorkbook.SaveAs Путь & ИмяФайла
    If Err Then MsgBox "Не удалось сохранить файл!", vbCritical: Exit Sub
    ' и т.д.
End Sub

В любом случае, всех возможных ошибок не предусмотришь…

Ладно, если было бы достаточно пары строк…
В случаях, когда любое из последовательных действий может вызвать ошибку, я сам использую подобные конструкции (например, в цикле открываем файл excel, в нем ищем определённый лист, на нём — некую таблицу, и т.д.)

В данном же случае, ИМХО, вполне достаточно и On Error Resume Next

Не спорю, полезно.
Но, если человеку нужен ОДИН работающий макрос, и он в будущем не намерен углубляться в дебри программирования, — его вполне устроит и «урезанный» вариант макроса.

Зачем пытаться предусмотреть все ошибки, не зная, на каких данных и оборудовании будет работать этот макрос?
Бывает, я пишу на форум макросы из 2 строк: первая — это On Error Resume Next, вторая — длинная строка типа этого:

1

MsgBox ActiveSheet.UsedRange.Find("текст").Next.Resize(3).Find("текст2").EntireRow.Cells(1)

Для своих нужд, я, конечно, такое бы не написал, но просящих помощи форумчан такие варианты более чем устраивают.

I’m not sure what is in your cells. But you can build a path from the values like this.

Dim ws As Excel.Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")

Dim szPath as string
szPath = ws.Range("B1").Value & "" & ws.Range("C1").Value

Open a folder
To open a folder you can use shellexecute. Declare this at the top of all you code. Above all subs and functions.

Private Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" _
  (ByVal hwnd As Long, _
   ByVal lpOperation As String, _
   ByVal lpFile As String, _
   ByVal lpParameters As String, _
   ByVal lpDirectory As String, _
   ByVal nShowCmd As Long) As Long

Then you can send it a path

    ShellExecute 0, "open", "C:Temp", 0, 0, 1
    'or send it the value build from the cells
    ShellExecute 0, "open", szPath , 0, 0, 1

You can also open files this way

Create files
If you want to create files it can be done like this.

Dim fs As FileSystemObject
Set fs = New FileSystemObject

'Create a text file
Set ts = fs.CreateTextFile("C:Temptest.txt", True, False)
'or using the path from the cells
Set ts = fs.CreateTextFile(szPath & "text.txt", True, False)

Create folders
And lastly you can create folders.

fs.CreateFolder ("C:TempSomeNewDir")
'or using the path from the cells
fs.CreateFolder (szPath & "SomeNewDir")

 Как проверить, существует ли папка, и не создать ли ее?

Вы когда-нибудь пытались проверить, существует ли папка на листе Excel? В этой статье я расскажу о том, как проверить, существует ли папка по указанному пути, в противном случае папка будет создана автоматически по указанному пути.

Проверьте, существует ли папка в определенном пути к файлу с кодом VBA

Создайте папку, если она не существует в определенном пути к файлу с кодом VBA

Проверьте, существует ли папка в определенном пути к файлу с кодом VBA

Следующий код VBA может помочь вам проверить, существует ли папка по определенному пути к файлу, сделайте следующее:

1. Удерживайте ALT + F11 , чтобы открыть Microsoft Visual Basic для приложений окно.

2. Нажмите Вставить > Модулии вставьте следующий код в Модули Окно.

Код VBA: проверьте, существует ли папка в определенном пути к файлу:

Sub Test_Folder_Exist_With_Dir()
'Updateby Extendoffice
    Dim sFolderPath As String
    sFolderPath = "C:UsersDT168DesktopTest folder"
    If Right(sFolderPath, 1) <> "" Then
        sFolderPath = sFolderPath & ""
    End If
    If Dir(sFolderPath, vbDirectory) <> vbNullString Then
        MsgBox "Folder exist", vbInformation, "Kutools for Excel"
    Else
        MsgBox "Folder doesn't exist", vbInformation, "Kutools for Excel"
    End If
End Sub

Примечание: В приведенном выше коде вы должны изменить путь и имя папки C: Users DT168 Desktop Test папка к вашему необходимому.

3, Затем нажмите F5 ключ для запуска этого кода, вы получите следующие результаты:

Создайте папку, если она не существует в определенном пути к файлу с кодом VBA

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

1. Удерживайте ALT + F11 , чтобы открыть Microsoft Visual Basic для приложений окно.

2. Нажмите Вставить > Модулии вставьте следующий код в Модули Окно.

Код VBA: создайте папку, если она не существует в пути к файлу:

Sub MakeMyFolder()
'Updateby Extendoffice
    Dim fdObj As Object
    Application.ScreenUpdating = False
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    If fdObj.FolderExists("C:UsersDT168DesktopTest folder") Then
        MsgBox "Found it.", vbInformation, "Kutools for Excel"
    Else
        fdObj.CreateFolder ("C:UsersDT168DesktopTest folder")
        MsgBox "It has been created.", vbInformation, "Kutools for Excel"
    End If
    Application.ScreenUpdating = True
End Sub

Внимание: В приведенном выше коде вы должны изменить путь и имя папки C: Users DT168 Desktop Test папка к вашему необходимому.

3. После вставки кода нажмите F5 ключ для его запуска:

(1.) Если папка существует, появится диалоговое окно, как показано на следующем снимке экрана:

(2.) Если папка не существует, она будет создана сразу по определенному пути, и появится окно подсказки, напоминающее вам, что папка была создана, см. Снимок экрана: