Excel Excel VBA - Copiar cada linha e colar em uma planilha diferente

[Maikon Lopes]

Boa tarde,

 

Estou precisando de ajuda para realizar uma macro para agilizar um trabalho que tenho que fazer.

 

Trata-se de uma planilha com vários códigos e algumas descrições .

 

Eu preciso que uma macro copie cada linha e cole em uma nova pasta do excel.

 

Exemplo: linha 2 copia e em uma nova pasta, e assim por diante. Se a planilha tiver 20 linhas, será necessário colocar copiar cada uma delas para uma nova pasta, ou seja 20 pastas.

 

 

Eu tentei criar uma macro, porém quando eu executo, ocorre um loop infinito e a planilha trava

 

"

Sub Salvar()
    Application.ScreenUpdating = False
    Range(Cells(2, 2), Cells(2, 6)).Select
    Do
    If ActiveCell <> "" Then
    Range(Cells(2 + 1, 2), Cells(2 + 1, 6)).Select
    End If
    Loop Until ActiveCell = ""
    Selection.Copy
    Workbooks.Add
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    
End Sub

"

 

 

 

Copiar linhas.xlsx

[Midori]

Com a propriedade CurrentRegion fica mais fácil copiar todo conteúdo, mas para isso a tabela não pode ter linhas ou colunas em branco.

 

Insira um módulo na planilha e teste a macro abaixo.

 

Sub Main()
    Dim Area    As Range
    Dim Pasta   As Workbook
    
    Set Area = Range("B2").CurrentRegion
    Set Pasta = Workbooks.Add
    
    Area.Copy Pasta.ActiveSheet.Range("B2")

End Sub

 

[Maikon Lopes]

Não seria desse jeito, eu preciso que cada linha seja copiada e colada em uma pasta diferente, pois desejo após isso salvar cada uma delas, para envio.

 

Seria como uma mala direta, mas sem enviar, apenas salvar em algum lugar.

[Midori]

Só para testar coloquei uma instrução para gerar apenas 3 linhas (Exit For).

 

Sub Main()
    Dim WkCopia As Worksheet
    Dim WkNova  As Workbook
    Dim L       As Integer
    
    Set WkCopia = ThisWorkbook.ActiveSheet
    
    For L = 3 To WkCopia.Range("B2").End(xlDown).Row
        Set WkNova = Workbooks.Add
        
        WkCopia.Range(L & ":" & L).Copy WkNova.ActiveSheet.Cells(1)
                
        If L >= 5 Then Exit For
    Next L
End Sub