Excel Criar pasta de acordo com o mês

[diego_janjao]

Pessoal, boa tarde.

Eu tenho uma planilha da qual ela cria uma pasta de acordo com o cliente e produto e coloca um arquivo dentro desta pasta, porém, eu gostaria que ela criasse uma pasta de acordo com o mês no formato "01.Janeiro" e colocasse essas pastas lá dentro, mas eu não estou conseguindo a parte de criar a pasta dos meses e consequentemente colocar as novas pastas dentro.

 

Private Sub Worksheet_change(ByVal Target As Range)
              
Dim Pasta   As Workbook
Dim raiz As Object, save
Set raiz = CreateObject("Scripting.FileSystemObject")

On Error Resume Next

             
       On Error GoTo aviso1
       
        If Target.Column = 7 And Target.Value <> "" Then 'PROCV DE CLIENTE
      
        Application.ScreenUpdating = False

        Cells(Target.Row, 5).Value = Date 'coloca data na coluna b
                            
        Cells(Target.Row, 8).Value = WorksheetFunction.VLookup(Cells(Target.Row, 7), Planilha4.Range("A2:I15000"), 3, False) 'Coloca CLIENTE
        Cells(Target.Row, 9).Value = WorksheetFunction.VLookup(Cells(Target.Row, 7), Planilha4.Range("A2:I15000"), 4, False) 'Coloca UF
        Cells(Target.Row, 71).Value = WorksheetFunction.VLookup(Cells(Target.Row, 7), Planilha4.Range("A2:I15000"), 5, False) 'Coloca DIVISÃO
                
        Application.ScreenUpdating = True
        
        End If
        
        If Target.Column = 10 And Target.Value <> "" Then 'PROCV DE PRODUTO
       
        Application.ScreenUpdating = False

        Cells(Target.Row, 11).Value = WorksheetFunction.VLookup(Cells(Target.Row, 10), Planilha6.Range("A2:D15000"), 2, False) 'Coloca PRODUTO
        Cells(Target.Row, 14).Value = WorksheetFunction.VLookup(Cells(Target.Row, 10), Planilha6.Range("A2:D15000"), 3, False) 'Coloca FÁBRICA
        Cells(Target.Row, 69).Value = WorksheetFunction.VLookup(Cells(Target.Row, 10), Planilha6.Range("A2:D15000"), 4, False) 'Coloca LINHA
        save = ThisWorkbook.Path & "\" & Format(Cells(Target.Row, 4).Value, "000000") & " - " & Cells(Target.Row, 8).Value & " - " & Cells(Target.Row, 11).Value

        If Not raiz.FolderExists(save) Then
        raiz.CreateFolder (save)
        
        End If
        
        FileCopy ThisWorkbook.Path & "\FOR004 - Não conformidade.xlsx", _
        ThisWorkbook.Path & "\" & Format(Cells(Target.Row, 4).Value, "000000") & " - " & Cells(Target.Row, 8).Value & " - " & Cells(Target.Row, 11).Value & "\SAC " & Format(Cells(Target.Row, 4).Value, "000000") & " - Investig.xlsx"
                
        Set Pasta = Workbooks.Open(ThisWorkbook.Path & "\" & Format(Cells(Target.Row, 4).Value, "000000") & " - " & Cells(Target.Row, 8).Value & " - " & Cells(Target.Row, 11).Value & "\SAC " & Format(Cells(Target.Row, 4).Value, "000000") & " - Investig.xlsx", _
        True)
        Pasta.ActiveSheet.[G5] = Format(Cells(Target.Row, 4).Value, "000000")
        Pasta.save
        Pasta.Close
                
        Application.ScreenUpdating = True
        
        End If
                               
        Exit Sub
aviso1:
MsgBox "Não foi possível localizar o item", vbOKOnly, "Atendimento ao Cliente Doremus"

     
End Sub

De antemão, agradeço a quem ajudar.

SAC.rar

[Basole]

@diego_janjao para criar uma pasta neste formato [ 01.Janeiro ], de acordo com a coluna "E", substitue

 

Esta linha:

 

 save = ThisWorkbook.Path & "\" & Format(Cells(Target.Row, 4).Value, "000000") & " - " & Cells(Target.Row, 8).Value & " - " & Cells(Target.Row, 11).Value

 

 

por esta:

 

save = ThisWorkbook.Path & "\" & VBA.Month(Cells(Target.Row, 5).Value) & "." & VBA.StrConv(VBA.MonthName(VBA.Month(Cells(Target.Row, 5).Value)), 3) 

 

[diego_janjao]

47 minutos atrás, Basole disse:

save = ThisWorkbook.Path & "\" & VBA.Month(Cells(Target.Row, 5).Value) & "." & VBA.StrConv(VBA.MonthName(VBA.Month(Cells(Target.Row, 5).Value)), 3)

 

Basole, muito obrigado pela ajuda... Mas acho que me expressei mal, eu ainda preciso que o comando de criação de pasta já existente continue, agora eu preciso que a pasta do código anterior, salve dentro da pasta que sua linha de código criou.

 

Tentei modificar aqui mas não deu certo.

----------------------------------------------------------------------------------------------------------

 

EDIT: Modifiquei a ordem aqui e deu certo, ficou assim:

 

Private Sub Worksheet_change(ByVal Target As Range)
              
Dim Pasta   As Workbook
Dim raiz As Object, save
Set raiz = CreateObject("Scripting.FileSystemObject")

On Error Resume Next

             
       On Error GoTo aviso1
       
        If Target.Column = 7 And Target.Value <> "" Then 'PROCV DE CLIENTE
      
        Application.ScreenUpdating = False

        Cells(Target.Row, 5).Value = Date 'coloca data na coluna b
                            
        Cells(Target.Row, 8).Value = WorksheetFunction.VLookup(Cells(Target.Row, 7), Planilha4.Range("A2:I15000"), 3, False) 'Coloca CLIENTE
        Cells(Target.Row, 9).Value = WorksheetFunction.VLookup(Cells(Target.Row, 7), Planilha4.Range("A2:I15000"), 4, False) 'Coloca UF
        Cells(Target.Row, 71).Value = WorksheetFunction.VLookup(Cells(Target.Row, 7), Planilha4.Range("A2:I15000"), 5, False) 'Coloca DIVISÃO
        save = ThisWorkbook.Path & "\" & VBA.Month(Cells(Target.Row, 5).Value) & "." & VBA.StrConv(VBA.MonthName(VBA.Month(Cells(Target.Row, 5).Value)), 3)
        
               
        If Not raiz.FolderExists(save) Then
        raiz.CreateFolder (save)
        
        Application.ScreenUpdating = True
        
        End If
        
        End If
        
        If Target.Column = 10 And Target.Value <> "" Then 'PROCV DE PRODUTO
       
        Application.ScreenUpdating = False

        Cells(Target.Row, 11).Value = WorksheetFunction.VLookup(Cells(Target.Row, 10), Planilha6.Range("A2:D15000"), 2, False) 'Coloca PRODUTO
        Cells(Target.Row, 14).Value = WorksheetFunction.VLookup(Cells(Target.Row, 10), Planilha6.Range("A2:D15000"), 3, False) 'Coloca FÁBRICA
        Cells(Target.Row, 69).Value = WorksheetFunction.VLookup(Cells(Target.Row, 10), Planilha6.Range("A2:D15000"), 4, False) 'Coloca LINHA
        save2 = ThisWorkbook.Path & "\" & VBA.Month(Cells(Target.Row, 5).Value) & "." & VBA.StrConv(VBA.MonthName(VBA.Month(Cells(Target.Row, 5).Value)), 3) & "\" & Format(Cells(Target.Row, 4).Value, "000000") & " - " & Cells(Target.Row, 8).Value & " - " & Cells(Target.Row, 11).Value

        If Not raiz.FolderExists(save2) Then
        raiz.CreateFolder (save2)
        
        End If
        
        FileCopy ThisWorkbook.Path & "\FOR004 - Não conformidade.xlsx", _
        ThisWorkbook.Path & "\" & VBA.Month(Cells(Target.Row, 5).Value) & "." & VBA.StrConv(VBA.MonthName(VBA.Month(Cells(Target.Row, 5).Value)), 3) & "\" & Format(Cells(Target.Row, 4).Value, "000000") & " - " & Cells(Target.Row, 8).Value & " - " & Cells(Target.Row, 11).Value & "\SAC " & Format(Cells(Target.Row, 4).Value, "000000") & " - Investig.xlsx"
                
        Set Pasta = Workbooks.Open(ThisWorkbook.Path & "\" & VBA.Month(Cells(Target.Row, 5).Value) & "." & VBA.StrConv(VBA.MonthName(VBA.Month(Cells(Target.Row, 5).Value)), 3) & "\" & Format(Cells(Target.Row, 4).Value, "000000") & " - " & Cells(Target.Row, 8).Value & " - " & Cells(Target.Row, 11).Value & "\SAC " & Format(Cells(Target.Row, 4).Value, "000000") & " - Investig.xlsx", _
        True)
        Pasta.ActiveSheet.[G5] = Format(Cells(Target.Row, 4).Value, "000000")
        Pasta.save
        Pasta.Close
                
        Application.ScreenUpdating = True
        
        End If
                               
        Exit Sub
aviso1:
MsgBox "Não foi possível localizar o item", vbOKOnly, "Atendimento ao Cliente Doremus"


     
End Sub