Dúvida Excel

[gabrielpxe]

Boa tarde, pessoal.

Tenho uma macro que divide os itens de uma tabela de acordo com uma categoria.

Exemplo: Tenho uma planilha com 10 tipos de tênis, porém, 5 desses tênis são de corrida e 5 são de jogar bola. Então a macro gera duas planilhas, cada uma com os 5 tênis de cada categoria. Porém na planilha gerada, estão os 5 tênis e abaixo deles cinco espaços vazios (que "pertenciam" aos tênis da outra categoria).

Preciso que na planilha gerada através da macro, tenha apenas os tênis da categoria, sem os espaços vazios.

Abaixo segue a macro que estou usando.

Sub Divide()

Dim iTotalLinhas As Long

Dim lGestor As String

Dim lNomeArquivo As String

Dim iTotLinhasNovo As Long

Dim lCaminho As String

Sheets("Dinamica").Select

ActiveSheet.PivotTables("Dinamica").PivotCache.Refresh

Worksheets("Path").Activate

lCaminho = CStr(Range("A1").Value)

Worksheets("Base").Activate

ActiveWorkbook.Worksheets("Base").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Base").Sort.SortFields.Add Key:=Range( _

"D2:D200000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

xlSortNormal

With ActiveWorkbook.Worksheets("Base").Sort

.SetRange Range("A1:AB20000")

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

iTotalLinhas = Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To iTotalLinhas

If lGestor <> Range("D" & CStr(i)).Value Then

If lGestor <> "" Then

Windows(lNomeArquivo).Activate

ActiveWorkbook.Save

Windows(lNomeArquivo).Close

Windows("RISCO ANATEL.XLSM").Activate

End If

lGestor = Range("D" & CStr(i)).Value

Workbooks.Add

lNomeArquivo = "" & lGestor & ".xls"

ActiveWorkbook.SaveAs Filename:= _

lCaminho & "\" & lNomeArquivo _

, FileFormat:=xlExcel8, CreateBackup:=False

Windows("RISCO ANATEL.XLSM").Activate

Range("A1:AB1").Copy

Windows(lNomeArquivo).Activate

ActiveSheet.Paste

Application.CutCopyMode = False

Windows("RISCO ANATEL.XLSM").Activate

Columns("A:AB").Select

Selection.Copy

Windows(lNomeArquivo).Activate

Columns("A:AB").Select

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False

Range("A" & i).Select

End If

Windows("RISCO ANATEL.XLSM").Activate

Range("A" & i & ":AB" & i).Copy

Windows(lNomeArquivo).Activate

iTotLinhasNovo = Cells(Rows.Count, 1).End(xlUp).Row + 1

Range("A" & iTotLinhasNovo & ":S" & iTotLinhasNovo).Select

Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

Windows("RISCO ANATEL.XLSM").Activate

Next

Windows(lNomeArquivo).Activate

ActiveWorkbook.Save

Windows(lNomeArquivo).Close

Windows("RISCO ANATEL.XLSM").Activate

Windows("RISCO ANATEL.XLSM").Activate

Application.CutCopyMode = False

Worksheets("Base").Activate

Range("A1").Activate

End Sub

Valeu pela ajuda!

[zinhovba]

Boa noite!!

Em quanto o pessoal não responde tente postar seu arquivo modelo em site gratuito, depois poste o link aqui!!

Att