gistfile1.txt

Dim pasta, textoparapesquisa, colunainicial, colunafinal, sigla As String
Dim linha, contador, inicio, final, vazios As Long

Private Sub ComboBoxArquivoOrigem_Change()
    ComboBoxPlanilhaOrigem.Clear
    ListaPlanilhasdoArquivo
End Sub

Private Sub OptionButtonEmpresas_Click()
    TextBoxCaminhoDestino.Text = pasta & "\empresas\"
    textoparapesquisa = "Empresa: "
    sigla = "-emp-"
    colunainicial = "A"
    colunafinal = ":K"
End Sub

Private Sub OptionButtonUnidades_Click()
    TextBoxCaminhoDestino.Text = pasta & "\unidades\"
    textoparapesquisa = "Unidade: "
    sigla = "-uni-"
    colunainicial = "A"
    colunafinal = ":K"
End Sub


Sub ListarArquivosAbertos()

    Dim wb As Workbook
    Dim row As Integer
    row = 1
    
    For Each wb In Application.Workbooks
        ComboBoxArquivoOrigem.AddItem wb.Name
    Next wb

End Sub

Sub ListaPlanilhasdoArquivo()

    Dim i As Integer 'variável para o índice da planilha
    Dim NumSheets As Integer 'variável para o número de planilhas

    Workbooks(ComboBoxArquivoOrigem.Text).Activate
    NumSheets = Sheets.Count 'obtém o número de planilhas
    For i = 1 To NumSheets 'repete para cada planilha
        ComboBoxPlanilhaOrigem.AddItem Sheets(i).Name
    Next i
    
    ComboBoxPlanilhaOrigem.ListIndex = 0


End Sub

Private Sub UserForm_Initialize()

    pasta = "C:\faturamento"
    On Error GoTo Erro
    If Dir(pasta, vbDirectory) = "" Then MkDir pasta
    If Dir(pasta & "\empresas", vbDirectory) = "" Then MkDir pasta & "\empresas"
    If Dir(pasta & "\unidades", vbDirectory) = "" Then MkDir pasta & "\unidades"
    
    OptionButtonEmpresas_Click
    ListarArquivosAbertos

Erro:


End Sub

Function FormatarNomeArquivo(str As String) As String

    Dim i As Long, letters As String, letter As String
    letters = vbNullString

    For i = 1 To Len(str)
        letter = VBA.Mid$(str, i, 1)
        If (Asc(LCase(letter)) >= 97 And Asc(LCase(letter)) <= 122) Or letter = Chr(32) Then
            letters = letters + letter
        End If
    Next
    FormatarNomeArquivo = Trim(letters)

End Function

Private Sub CommandButtonIniciar_Click()
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Workbooks(ComboBoxArquivoOrigem.Text).Activate
    
    Dim ws As Worksheet
    Set ws = Workbooks(ComboBoxArquivoOrigem.Text).Worksheets.item(ComboBoxPlanilhaOrigem.ListIndex + 1)
    
    Dim data As String
    data = Format(Date, "yyyy-mm-dd")

    Dim flag As Boolean
    flag = False
    linha = 1
    contador = 0
    inicio = 0
    final = 0

    While Not flag
        
        If IsEmpty(ws.Cells(linha, 1)) Then
            contador = contador + 1
            If contador > 10 Then
                flag = True
            End If
        Else
            contador = 0
        End If

        If InStr(ws.Cells(linha, 1).Value, textoparapesquisa) = 1 Then
            inicio = linha
            final = linha + 1
            vazios = 0

            Do
                final = final + 1
                If InStr(ws.Cells(final, 1).Value, textoparapesquisa) = 1 Or vazios = 10 Then Exit Do
                If IsEmpty(ws.Cells(final, 1)) Then vazios = vazios + 1
            Loop
            Range(colunainicial & inicio & colunafinal & final - 1).Copy
            
            Dim item As String
            item = Replace(ws.Cells(linha, 1).Value, textoparapesquisa, "")
            item = FormatarNomeArquivo(item)
            
            Workbooks.Add
            Set novoarquivo = ActiveWorkbook
            Worksheets.item(1).Name = TextBoxNomePlanilhaDestino.Text
            Worksheets.item(1).Paste
            Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
            novoarquivo.SaveAs Filename:=TextBoxCaminhoDestino & data & sigla & item & ".xls", FileFormat:=xlExcel7
            novoarquivo.Save
            novoarquivo.Close
            Debug.Print item & " Inicio:" & inicio & " Final:" & final
            
        End If
        linha = linha + 1
    Wend

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Finalizado"
    UserFormSeparacao.Hide
    Unload UserFormSeparacao
    
End Sub