Código e VBA para separar informações em diferntes arquivos

gistfile1.txt

Dim linha, contador, inicio, final, vazios As Long

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 = letters
End Function

Sub Iniciar()

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Fatura 1")
    
    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, "Empresa:") > 0 Then
            inicio = linha
            final = linha + 1
            vazios = 0
            
            Do
                final = final + 1
                If InStr(ws.Cells(final, 1).Value, "Empresa:") > 0 Or vazios = 10 Then Exit Do
                If IsEmpty(ws.Cells(final, 1)) Then vazios = vazios + 1
                
            Loop
            Range("A" & inicio & ":K" & final - 1).Copy
            
            Dim empresa As String
            empresa = Replace(ws.Cells(linha, 1).Value, "Empresa:", "")
            empresa = FormatarNomeArquivo(empresa)
            
            Workbooks.Add
            Set novoarquivo = ActiveWorkbook
            Worksheets.Item(1).Name = "Fatura 1"
            Worksheets.Item(1).Paste
            Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Range("A1").Activate
            
            novoarquivo.SaveAs Filename:="C:\Users\Administrator\Desktop\" & empresa & ".xls"
            novoarquivo.Save
            novoarquivo.Close
            
            Debug.Print empresa & " Inicio:" & inicio & " Final:" & final
    
            
        End If
        linha = linha + 1
        
    Wend
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub