EXCELer

Código num módulo:

Sub MakeToolBar()
 
    On Error Resume Next
    Application.CommandBars("MyToolBar").Delete
    On Error GoTo 0


    With Application.CommandBars.Add(Name:="MyToolBar", _
                                     Position:=msoBarTop, MenuBar:=False)

        .Protection = msoBarNoCustomize


        With .Controls.Add(Type:=msoControlButton)
            .Style = msoButtonCaption
            .DescriptionText = "Imprime, Grava e Sai"
            .TooltipText = "Imprime, Grava e Sai"
            .Caption = "Imprime/Grava/Sai"
            .OnAction = "Imprime_Grava" 
        End With

        With .Controls.Add(Type:=msoControlButton)
            .Style = msoButtonCaption
            .DescriptionText = "Limpar os Dados Anteriores"
            .TooltipText = "Limpa os Dados Anteriores"
            .Caption = "Limpa Dados"
            .OnAction = "Limpa"
        End With

        With .Controls.Add(Type:=msoControlButton)
            .Style = msoButtonCaption
            .DescriptionText = "Gravar o Novo Mês"
            .TooltipText = "Grava o Novo Mês"
            .Caption = "Novo Mês"
            .OnAction = "GravaSai"
        End With

        With .Controls.Add(Type:=msoControlButton)
            .Style = msoButtonCaption
            .DescriptionText = "Inserção do valor que vem do fecho do mês anterior"
            .TooltipText = "Digitar o Valor do Mês Anterior"
            .Caption = "Valor Mês Anterior"
            .OnAction = "Valor_Anterior"
        End With

        Application.CommandBars("MyToolBar").Visible = True

    End With
End Sub

Sub DeleteToolBar()
    Dim bar As CommandBar
    On Error Resume Next
    Application.CommandBars("MyToolBar").Delete
    On Error GoTo 0
End Sub

Código no Workbook:

Private Sub Workbook_Activate()

    On Error Resume Next

    With Application.CommandBars("TranslateIT")
        .Enabled = False
        .Visible = False
    End With

    MakeToolBar

    On Error GoTo 0
End Sub


Private Sub Workbook_Deactivate()

Se pretendermos  usar o Excel para listar o conteúdo de um directório ou de uma pasta, mostrando cada nome de ficheiro numa célula de uma coluna (no exemplo, coluna A) e mostrando, igualmente a data/hora na célula correspondente da coluna seguinte e ainda fazer com que as colunas fiquem com a sua largura ajustada ao tamanho do  nome do ficheiro mais extenso, como no exemplo:

podemos utilizar o seguinte código:

' A partir do código apresentado num newsgroup por Tom Ogilvy

Sub ListDirectory()
Dim Msg As String
Dim rw As Long
Dim i As Long
Dim sDir As String
Msg = InputBox("Escolha o Path:")
sDir = Msg


If Len(Trim(Msg)) = 0 Then
  MsgBox "Não seleccionou nada . . ."
  Exit Sub
End If


With Application.FileSearch
    .NewSearch
    .LookIn = sDir
    .SearchSubFolders = True
    .FileName = "*.*"
    .FileType = msoFileTypeAllFiles
    rw = 2
    If .Execute() > 0 Then
    Sheets("Sheet1").Range("A:A").Clear

        For i = 1 To .FoundFiles.Count
            Sheets("Sheet1").Cells(rw, "A").Value = Dir(.FoundFiles(i))
            Sheets("Sheet1").Cells(rw, "B").Value = FileDateTime(.FoundFiles(i))
            rw = rw + 1
        Next i
    Else
        MsgBox "Não foram encontrados ficheiros"
    End If
End With
Sheets("Sheet1").Cells(1, 1).Value = "Nome do Ficheiro"
Sheets("Sheet1").Cells(1, 2).Value = "Data/Hora"
Columns("A:B").AutoFit
End Sub

Se pretendermos transformar Nome e Apelido em Apelido, Nome como no exemplo:

podemos utilizar a seguinte fórmula (créditos para Bob Phillips):

=MID(A1;FIND(" "A1)+1;255)&", "&LEFT(A1;FIND(" "A1))

Mas se pretendermos o contrário, ou seja, transformar Apelido, Nome em Nome e Apelido como no exemplo:

então, poderemos utilizar, a partir da fórmula anterior, a seguinte fórmula alterada:

=MID(A2;FIND(" ";A2)+1;255)&" "&LEFT(A2;FIND(", ";A2)-1)

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