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

    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

Ex:

de



para



O Código do CommandButton:

Private Sub CommandButton2_Click()
    Cells(ActiveCell.Row, 1).Activate
End Sub

Se tivermos uma tabela na Sheet2, como no exemplo:







Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Set rng1 = ActiveCell      'Clicar duplamente sempre numa célula da coluna A,
                               'para que a função Offset() possa indicar o número da célula pretendida
    Set rng2 = rng1.Offset(0, 1)
    Set rng3 = rng1.Offset(0, 2)

    rng2.Copy Destination:=Worksheets("Sheet1").[B3:D3]    ' Range, porque são merged cells
    rng3.Copy Destination:=Worksheets("Sheet1").[E3]  'altera a formatação no destino - é valor

    Range("A1").Select    ' Esta selecção de A1, é apenas para desactivar a ActiveCell
End Sub



Aqui, o resultado seria o seguinte:









teremos que aperfeiçoar o Código:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Set rng1 = ActiveCell      'Clicar duplamente sempre numa célula da coluna A,
                               'para que a função Offset() possa indicar o número da célula pretendida
    Set rng2 = rng1.Offset(0, 1)
    Set rng3 = rng1.Offset(0, 2)

    rng2.Copy Destination:=Worksheets("Sheet1").[B3:D3]    ' Range, porque são merged cells
    rng3.Copy
    Worksheets("Sheet1").[E3].PasteSpecial (xlValues) 'não altera a formatação no destino apesar de ser valor
    
    [A1].Select    ' Esta selecção de A1, é apenas para desactivar a ActiveCell
End Sub

podemos fazê-lo da seguinte maneira:

• Criamos a TextBox:

O resultado será o esperado:





E o resultado será:




O Código da macro:

Sub TboxValueInCell()
    Dim ws1 As Worksheet
    Dim rng As Range
    Dim tb As TextBox
    Dim newtext

    Set ws1 = Sheets("Sheet1")
    Set rng = ws1.Range("C8")
    Set tb = ws1.TextBoxes("Text01")
    
    newtext = tb.Text
    rng = newtext

End Sub

Se pretendermos copiar o conteúdo de determinadas células contidas numa linha para outra Sheet e para células diferentes, como no exemplo:



O resultado:



Podemos utilizar a chamada OffSet Property.

Nota1: Para copiar o conteúdo da linha pretendida da Sheet1 para a Sheet2, faz-se um duplo clic na célula da coluna A cuja linha queremos copiar
Nota2: Para colocar o Código VBA, clicar no tabulador da Sheet1 com o botão direito do rato e escolher View Code

O Código:

'---------------------------------------------------------------------------------------
' Procedure : Worksheet_BeforeDoubleClick
' DateTime  : 18-10-2006 15:25
' Author    : JRod
' Purpose   : Copiar conteúdo de células da Sheet1 para células diferentes da Sheet2
'---------------------------------------------------------------------------------------
'
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Set rng1 = ActiveCell
    Set rng2 = rng1.Offset(0, 1)
    Set rng3 = rng1.Offset(0, 2)
    Set rng4 = rng1.Offset(0, 3)

    rng1.Copy Destination:=Worksheets("Sheet2").Range("D4:E4")
    rng2.Copy Destination:=Worksheets("Sheet2").Range("G4:H4")
    rng3.Copy Destination:=Worksheets("Sheet2").Range("C4")
    rng4.Copy Destination:=Worksheets("Sheet2").Range("C7:D7")

    Range("A1").Select
    
End Sub

Tópicos relacionados

 OffSet Property
 CurrentRegion Property
 
 

Vejamos o seguinte exemplo:






Então, o que poderemos fazer, será:



ou seja, clica-se no quadrado da intersecção entre a coluna A e a linha1.

Depois, clica-se no ícone "Format Painter". O resultado será a marcação de toda a worksheet:






O resultado será, então, o desejado:

Se pretendermos inserir uma imagem numa folha de cálculo e dentro de uma "Image box control", como no exemplo:








podemos utilizar um pouco de Código:

Option Explicit


Private Sub CommandButton1_Click()

    Dim myPictName As Variant
    Dim Image1 As Image

    myPictName = Application.GetOpenFilename _
                    (filefilter:="Picture Files,*.jpg;*.bmp;*.tif;*.gif")
    If myPictName = False Then
        Exit Sub
    End If


   Me.Image1.Picture = LoadPicture(myPictName)

End Sub

Se numa tabela de nomes pretendermos filtrar um determinado nome (ex: António), o qual pode ser nome próprio, nome do meio ou apelido, podemos utilizar um pouco de VBA:












O Código:

Private Sub CommandButton1_Click()
Dim myName

    Range("A1:A700").Select
    myName = InputBox(Prompt:="Digite o nome para filtro ou carregue em OK para remover filtro", Title:="Filtra por nome")

    If myName = "" Then
        Selection.AutoFilter
        Range("A1").Select
    Else
        Selection.AutoFilter Field:=1, Criteria1:="*" & myName & "*", Operator:=xlAnd
        Range("A1").Select
    End If

End Sub


NOTA: O asterisco funciona como um "multi character wild card".

Tópicos relacionados

 WildCards (1) (Microsoft Support Center)

 WildCards (2) (digdb.com)

 Filtros (1) (por Debra Dalgleish)

 Filtro (2) (Joseph Rubin's Exceltip.com)

O Código:

Private Sub CommandButton1_Click()
    Dim strTemp As String

    On Error GoTo CommandButton1_Click_Error

    Open "F:\Gabinete\teste.txt" For Input As #1

    Line Input #1, strTemp
    Range("A1").Value = strTemp + 1
    Close #1

    Open "F:\Gabinete\teste.txt" For Output As #1

    strTemp = Range("A1").Value
    Print #1, strTemp
    Close #1

    On Error GoTo 0
    Exit Sub

CommandButton1_Click_Error:

    MsgBox "Erro " & Err.Number & " (" & Err.Description & ") no procedimento CommandButton1_Click"
End Sub

Tópicos relacionados:

 Open Statement

Consideremos o seguinte sistema de equações: x + y =8 e x - y = 2

Assim, na 2ª equação, teriamos: x= y+2. Então, na 1ª equação teríamos com a substituição de x: y + 2 + y = 8 ou seja: 2y = 6 ou seja: y = 6/2 ou seja: y = 3

Então, na 2ª equação teríamos com a substituição de y pelo seu resultado: x - 3 = 2 ou seja: x = 5

Como resolver este problema no Excel?

Com a ajuda do Add-in SOLVER, é possível. Vejamos o exemplo:

Nota - definiu-se C2 como x e C3 como y (Insert|Name|Define)
            B2 é igual a 8, ou seja: x + y
            B3 é igual a 2, ou seja: x - y








O resultado: