EXCELer

No último post, vimos como se podiam colar dados na Folha2 provenientes da Folha1. Mas e se os dados a serem colados forem provenientes de selecções múltiplas, ou seja, de ranges não contínuos? Como efectuar estas cópias múltiplas e como colar na Folha2 , mas de modo contínuo, linha a linha?

Para uma melhor compreensão, vejamos o exemplo:

 Escolha na Folha1:

Resultado na Folha2:

O Código:

Para o Command Button:

Private Sub Teste_Click()
    Call Faz_Tudo
End Sub

Num módulo VBE:

Option Explicit
Sub Faz_Tudo()


    Dim LotsOfRanges() As Range
    Dim rangeCtr As Long
    Dim myRange As Range
    Dim myArea As Range
    Dim i As Long
    Dim destrange As Range


    rangeCtr = 0
    Do
        On Error Resume Next
        Set myRange = Nothing
        Set myRange = Application.InputBox(prompt:="Seleccionar o Range" _
                                & rangeCtr + 1, _
                              Title:="Any Range", _
                              Default:=Selection.Address, _
                              Type:=8)
        On Error GoTo 0
        If myRange Is Nothing Then
            'Cancelamento pelo utilizador
            Exit Do
        Else
            rangeCtr = rangeCtr + 1
            ReDim Preserve LotsOfRanges(1 To rangeCtr)
            Set LotsOfRanges(rangeCtr) = myRange
        End If
    Loop


    If rangeCtr = 0 Then
        'Cancela o primeiro e sai
        
        Exit Sub
    End If


    If MsgBox("Pronto para processar os Ranges?", vbYesNo) = vbNo Then
        Exit Sub
    End If


    For i = LBound(LotsOfRanges) To UBound(LotsOfRanges)
        For Each myArea In LotsOfRanges(i).Areas
        
        
                Set destrange = Sheets("Sheet2").Range("A" & _
                                               LastRow(Sheets("Sheet2")) + 1)
        myArea.Copy
        destrange.PasteSpecial xlPasteValues, , False, False
        Application.CutCopyMode = False
        Next myArea
    Next i


End Sub


Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

A propósito do post de 2006-12-03 (agora catalogado com o nº 173), fizeram a seguinte pergunta:

"O código só copia e cola as celulas A, B,C e D da linha seleccionada se a célula da coluna A estiver seleccionada. Se a célula da coluna D estiver seleccionada vai copiar e colar as células à direita da mesma, ora o que eu pretendia se possivel era:

Nas colunas A, B, C estão inscritos dados que não serão alterados (Lista ou base dados) e na coluna D irá escrever-se o nº de unidades pedidas. Após a inscrição das unidades pedidas na coluna D, activar-se-ia o CommandBoton para que o pedido passasse para a Folha2, colando os dados que estão nas colunas A, B, C e D dessa linha e o pedido seguinte na linha imediatamente a seguir."

Neste caso, o Código deverá ser alterado para o seguinte:

Private Sub CommandButton2_Click()

    Dim MyNum

    For MyNum = 2 To 50

        If ActiveCell.Address = Range("D" & MyNum).Address Then
            Range(ActiveCell, ActiveCell.Offset(0, -3)).Copy Destination:= _
                                                             Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            msg = MsgBox(Prompt:="Copiou com sucesso", Title:="Informação")
        End If

    Next MyNum

End Sub

Ou seja, se a célula activa estiver na coluna D (no código acima é uma das células da coluna D compreendida entre D2 e D50), efectua a cópia e dá mensagem de bem sucedida a cópia, caso contrário, ou seja, se a célula activa não for uma célula da coluna D, não copia nada, pura e simplesmente.

Para apagar, na ultima linha editada, os valores das células correspondentes às colunas A, B , C , D e E, como no exemplo:

Podemos utilizar o seguinte Código:

Private Sub CommandButton1_Click()