Macro para salvar várias planilhas com base no valor da célula

Question

Boa noite pessoal da comunidade, diariamente tenho que enviar um relatório para vários vendedores e promotores de vendas com a planilha anexada, acontece, que eu tenho que salvar a pasta de trabalho com base no nome que está coluna de vendedores, exemplo a coluna tem vários vendedores, eu filtro o primeiro nome , salvo numa pasta com o mesmo nome, depois eu tiro o filtro, vou para o próximo nome que está na célula, salvo numa pasta com o mesmo nome, faço isso também com os promotores ,até acabar todos os nomes, quero criar uma macro para poder automatizar essa tarefa repetitiva, com isso, acho que vou ganhar bastante tempo, como posso criar essa macro?

Desde já Agradeço quem puder ajudar

Answer 1

Esta resposta foi traduzida automaticamente. Como resultado, pode haver erros gramaticais ou palavras estranhas.

Classifique a coluna K primeiro e, em seguida, altere "D" para "K" no código anterior. Em seguida, execute-o.

Answer 2

É a couna K

Answer 3

Esta resposta foi traduzida automaticamente. Como resultado, pode haver erros gramaticais ou palavras estranhas.

Qual coluna são os vendedores?

Aqui está um código baseado na coluna D.

Nota: Classifique a coluna primeiro.

====================

Sub SplitFile()

    Dim lastRow As Long

    Dim currentRow As Long

    Dim currentName As String

    Dim currentPath As String

    Dim ws As Worksheet

    Dim newBook As Workbook

    Dim previousName As String

    Set ws = ActiveSheet

    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    currentPath = ThisWorkbook.Path & "\"

    previousName = ""

    For currentRow = 2 To lastRow

        currentName = ws.Cells(currentRow, "D").Value

        If currentName = previousName Then

            ws.Rows(currentRow).Copy ActiveWorkbook.Sheets(1).Rows(j)

            j = j + 1

        Else

            If Not newBook Is Nothing Then

                newBook.SaveAs currentPath & previousName & ".xlsx"

                newBook.Close SaveChanges:=False

            End If

            Set newBook = Workbooks.Add

            ws.Rows(1).EntireRow.Copy newBook.Sheets(1).Rows(1)

            ws.Rows(currentRow).Copy newBook.Sheets(1).Rows(2)

            j = 3

        End If

        previousName = currentName

    Next currentRow

    If Not newBook Is Nothing Then

        newBook.SaveAs currentPath & previousName & ".xlsx"

        newBook.Close SaveChanges:=False

    End If

End Sub

====================

Answer 4

Bom Dia Snow Lu MSFT segue o link da planilha:

Base de Clientes Campinas 22.03.xlsx

Answer 5

Esta resposta foi traduzida automaticamente. Como resultado, pode haver erros gramaticais ou palavras estranhas.

Você poderia nos compartilhar um arquivo de teste? Então vou ter uma tentativa.

Para compartilhar uma pasta de trabalho de exemplo, carregue no OneDrive ou em qualquer outra unidade de nuvem. Então poste um link aqui.

Por que um arquivo de exemplo é importante para a solução de problemas. Como fazer. - Comunidade Microsoft