Como já percebi que a tabela ajuda, eis a minha tabela. Deixei com 100 registros por causa do tamanho, mas tem 1.000.000. Estou lendo várias publicações do fórum mas e testando algumas soluções mas não tenho sucesso.

Boa tarde Alessandro

Seja bem-vindo ao fórum!

Movi teu tópico para VBA & Macros, que é o assunto da tua dúvida.
Aonde você havia postado, não é permitido postar dúvidas, pois é exclusivo para a apresentação dos novos usuários do fórum.

Para facilitar a tua participação no fórum, sugiro tomar conhecimento do conteúdo dos links abaixo:
viewtopic.php?f=7&t=203
viewtopic.php?f=7&t=7903
viewtopic.php?f=7&t=3841
viewtopic.php?f=7&t=16757
viewtopic.php?f=7&t=12600
viewtopic.php?f=7&t=3371

[]s
Patropi - Moderador

Obrigado Patropi,

Vou aguardar sobre o problema e ler sobre as orientações.

Grato

Boa tarde, Ale.Bruno. Seja bem vindo.

Uma solução poderia ser:

Sub DivideEmArquivos()
  Const NumRegPorGrupo As Integer = 1000 'Divisão de 1000 em 1000 registros
  Dim wbBase As Workbook, wsBase As Worksheet, rgBase As Range, NomeWbBase As String
  Dim rgCabeçalho As Range
  Dim wbFilho As Workbook, wsFilho As Worksheet, rgFilho As Range, NomeWbFilho As String
  Dim NumReg As Long, NGrupos As Integer, i As Integer
  Set wbBase = ThisWorkbook
    NomeWbBase = Left(wbBase.Name, InStrRev(wbBase.Name, ".") - 1)
  Set wsBase = wbBase.Worksheets("Base")
  Set rgBase = wsBase.Range("A1").CurrentRegion
  Set rgCabeçalho = rgBase.Rows(1)
  Set rgBase = rgBase.Offset(1, 0).Resize(RowSize:=rgBase.Rows.Count - 1)
  NumReg = rgBase.Rows.Count
  NGrupos = Int((NumReg / NumRegPorGrupo) + 0.5)
  Application.ScreenUpdating = False
  For i = 0 To NGrupos - 1
     Set rgFilho = Union(rgCabeçalho, rgBase.Offset(i * NumRegPorGrupo, 0).Resize(RowSize:=NumRegPorGrupo))
     Set wbFilho = Workbooks.Add
     Set wsFilho = wbFilho.Worksheets(1)
     rgFilho.Copy Destination:=wsFilho.Range("A1")
     NomeWbFilho = wbBase.Path & "" & NomeWbBase & Format(i + 1, "00") & ".xlsx"
     wbFilho.SaveAs Filename:=NomeWbFilho, FileFormat:=xlOpenXMLWorkbook
     wbFilho.Close
     Set wbFilho = Nothing
  Next i
  Application.ScreenUpdating = True
  Set wbBase = Nothing:      Set wsBase = Nothing:   Set rgBase = Nothing
  Set rgCabeçalho = Nothing: Set wsFilho = Nothing:  Set rgFilho = Nothing
End Sub

Boa noite!

Estou postando esta escrita diferente do EdsonBR, pois percebi que o código não gera o restante das linhas quebradas <> 5000, ou seja no arquivo de exemplo ele gera 3 arquivos de 5001 linhas e desconsidera as 914 restantes que seria o 4o arquivo. Se seu arquivo sempre terminar em divisiveis por 5.000 o código acima lhe atenderá perfeitamente, porém se for quebrado tente este.
Valeu EdsonBR pelo seu código!

Vbajr10, boa noite!

Agradeço por ter apontado a falha. Ela está na linha:
NGrupos = Int((NumReg / NumRegPorGrupo) + 0.5)

onde minha intenção era forçar o arredondamento da quantidade de grupos pro valor imediatamente acima justamente prá prevenir essa situação de registros não múltiplos de 5.000 (ou outro valor qualquer). Obviamente não funcionou, pois não me dei conta que a função int() não faz esse arredontamento, mesmo somando 0.5 ao final.

A linha pode então ser substituída por:

NGrupos = (NumReg NumRegPorGrupo) - ((NumReg Mod NumRegPorGrupo) > 0)

Por esse motivo é sempre bom uma outra visão do mesmo problema, outras formas de resolvê-lo, pois a gente sempre sai ganhando. Por isso é que quando se trata de revisão/correção deve-se dar preferência a que outra pessoa o faça. Dou maior valor.

Prá me redimir, aqui o código corrigido:

Sub DivideEmArquivos()
  Const NumRegPorGrupo As Integer = 5000 'Divisão de 5000 em 5000 registros
  Dim wbBase As Workbook, wsBase As Worksheet, rgBase As Range, NomeWbBase As String
  Dim rgCabeçalho As Range
  Dim wbFilho As Workbook, wsFilho As Worksheet, rgFilho As Range, NomeWbFilho As String
  Dim NumReg As Long, NGrupos As Integer, i As Integer
  Set wbBase = ThisWorkbook
    NomeWbBase = Left(wbBase.Name, InStrRev(wbBase.Name, ".") - 1)
  Set wsBase = wbBase.Worksheets("Base")
  Set rgBase = wsBase.Range("A1").CurrentRegion
  Set rgCabeçalho = rgBase.Rows(1)
  Set rgBase = rgBase.Offset(1, 0).Resize(RowSize:=rgBase.Rows.Count - 1)
  NumReg = rgBase.Rows.Count
  NGrupos = (NumReg  NumRegPorGrupo) - ((NumReg Mod NumRegPorGrupo) > 0)
  Application.ScreenUpdating = False
  For i = 0 To NGrupos - 1
     Set rgFilho = Union(rgCabeçalho, rgBase.Offset(i * NumRegPorGrupo, 0).Resize(RowSize:=NumRegPorGrupo))
     Set wbFilho = Workbooks.Add
     Set wsFilho = wbFilho.Worksheets(1)
     rgFilho.Copy Destination:=wsFilho.Range("A1")
     NomeWbFilho = wbBase.Path & "" & NomeWbBase & Format(i + 1, "00") & ".xlsx"
     wbFilho.SaveAs Filename:=NomeWbFilho, FileFormat:=xlOpenXMLWorkbook
     wbFilho.Close
     Set wbFilho = Nothing
  Next i
  Application.ScreenUpdating = True
  Set wbBase = Nothing:      Set wsBase = Nothing:   Set rgBase = Nothing
  Set rgCabeçalho = Nothing: Set wsFilho = Nothing:  Set rgFilho = Nothing
End Sub

Obrigado novamente!