Notifications
Clear all

Dividir uma planilha em varias outras

4 Posts
2 Usuários
0 Reactions
1,266 Visualizações
(@vfsjunior)
Posts: 0
New Member
Topic starter
 

Ola , tenho um arquivo excel, com 63000 linhas de registros em uma planilha, preciso dividir essa planilha geral em varias planilhas de 1000 linhas, inclusive renomeando o nome de cada planilha, isso é possivél?

 
Postado : 22/11/2014 10:00 am
(@rlm)
Posts: 0
New Member
 

Veja se consegue adaptar o modelo anexo a sua realidade

 
Postado : 22/11/2014 10:46 am
(@vfsjunior)
Posts: 0
New Member
Topic starter
 

Ola RLM, quase isso, o que realmente preciso é pegar 1000 em 1000 linhas e clocar em sheets entende,

 
Postado : 24/11/2014 4:27 pm
(@rlm)
Posts: 0
New Member
 

Que era assim eu entendi, pois o objetivo e que se aprenda, e como não forneceu dados completos acreditei que poderia/saberia adaptar.
Veja se avança

Sub GerarSheets()
'declarei as variaveis
Dim Nome As String
Dim lin As Long, linFinal As Long, lin_aux As Long, rN As Long
    
'Inibe tela e algumas mensagens e melhora a performance da macro
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
'ativa planilha base
Sheets(1).Activate
'Determina a ultima linha com dados
linFinal = Range("A1048576").End(xlUp).Row
    
Cells(2, 1).Activate
Range("A2").Select
'laço para percorrer a base de dados
For lin = 2 To linFinal Step 10 'Aqui de dez em dez altere se necessario
    'Inclui nova sheet
    Sheets.Add After:=Sheets(Sheets.Count)
    'Utiliza o valor de uma celula como nome da planilha ou outro parametro
    Nome = lin - 1 'Worksheets(1).Cells(lin, 1).Value
    ActiveSheet.Name = Nome
    lin_aux = 2
    Sheets(1).Activate
    Range(Cells(1, 1), Cells(1, 9)).Copy 'Copia cabecalho range a1:I1 -- altere para sua range
    Sheets(Nome).Activate
    Cells(1, 1).PasteSpecial
        
    'Copia range estipulada aqui vai de 10 em 10 -- altere para sua range
    If lin + 9 <= linFinal Then
        rN = lin + 9
    Else
        rN = linFinal
    End If
    Sheets(1).Activate
    Range(Cells(lin, 1), Cells(rN, 9)).Copy
    Sheets(Nome).Activate
    Cells(lin_aux, 1).PasteSpecial
    ActiveWindow.Zoom = 100
    Columns("A:I").ColumnWidth = 13
    Range("A2").Select
    Sheets(1).Select
Next
Sheets(1).Select
Range("A2").Select
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .CutCopyMode = False
End With
'exibe mensagem ao final do processo
MsgBox "Fim do Processo", vbInformation + vbOKOnly, "Aviso de Sistema"
End Sub
 
Postado : 25/11/2014 10:27 am