Blog Archive

About Me

A minha fotografia
JRod - PORTUGAL
Microsoft [MVP] - Excel (10º ano consecutivo)
Ver o meu perfil completo
Com tecnologia do Blogger.

Seguidores

Estatisticas

Free Blog Counter

eXTReMe Tracker
Ocorreu um erro neste dispositivo
2006-12-21

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

2006-12-15

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.

2006-12-14

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()


    i = 5
    t = True


    While t = True
        i = i + 1
        If Cells(i, 1).Value = "" Then t = False
    Wend


    Range("a" & (i - 1)).Select
    Range(ActiveCell, ActiveCell.Offset(0, 4)).ClearContents


End Sub

2006-12-12
Se se pretender mudar a célula selecionada para uma outra na mesma linha mas na coluna "A", que código utilizar para mover a selecção, tendo em conta que a selecção inicial pode estar a 1, 2, 3, etc. células de "distância" na mesma linha?

Ex:

de



para



O Código do CommandButton:

Private Sub CommandButton2_Click()
    Cells(ActiveCell.Row, 1).Activate
End Sub
2006-12-03
Se pretendermos copiar um determinado range de uma Sheet para uma outra Sheet, mas para a linha vazia seguinte e mantendo dados em outras células da mesma linha onde se pretendem colar os dados, como no exemplo seguinte:







Podemos utilizar o seguinte Código num CommandButton:

Private Sub CommandButton1_Click()
    Range(ActiveCell, ActiveCell.Offset(0, 3)).Copy Destination:= _
                              Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End Sub


Nota: Neste exemplo, torna-se necessário que a ActiveCell seja sempre uma célula da coluna "A"