VBA Excel Intermediário - Usando PROCH no VBA - How to use the HLOOKUP Function - RetHLookup

VBA Excel Intermediário - Usando PROCH no VBA - How to use the HLOOKUP Function - RetHLookup

​

Sim, a velha e conhecida PROCH. Usá-la de forma programática pode facilitar muitíssimo o modo como passamos informações parametrizáveis para serem rapidamente encontradas em uma ou mais planilhas.

Function RetHLookup (nValue As Single, nRng As Range, nColReturn As Integer) As Variant

    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardess@gmail.com

    '        Date: 20/07/2016 - 18:54

    ' Application: Field Force Dashboard Analysis® - © ALLERGAN 2016, Inc. Todos os direitos reservados.

    '     Company: © ALLERGAN 2016, Inc. Todos os direitos reservados.

    '     Purpose: Return value from reference.

    '                    Let a= RetHLookup (1295359, Sheets("Par01").Range("L34:Z35"), 2)

    Let RetHLookup = Application.WorksheetFunction.HLookup(nValue, nRng, nColReturn, False)

End Function

É claro que um código muito similar pode e deve ser usado para PROCV.

Se gostou, compartilhe este post com outros! Deixe seus comentários e sugestões.

brazilsalesforceeffectiveness@gmail.com

VBA Intermediário - Função Converte um Range numa String - Range to String - Function ConRngInStr

VBA Intermediário - Função Converte um Range numa String - Range to String - Function ConRngInStr

​

O que segue abaixo é uma função que permite converter o intervalo contido num Range numa String para apresentação dentro de uma célula.

Function ConRngInStr 

(tgtRange As Range, Separator As String) As String

    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardess@gmail.com

    '        Date: 20/07/2016 - 09:15

    ' Application: Field Force Dashboard Analysis®

    '     Purpose: Função Converte um Range numa String - Range to String

    

If tgtRange Is Nothing Then Exit Function

 

Dim nCells As Range

For Each nCells In tgtRange.Cells

    Let ConRngInStr = ConRngInStr & Separator & nCells

Next nCells

 

Let ConRngInStr = Right(ConRngInStr, Len(ConRngInStr) - 1)

End Function

Se gostou, compartilhe este post com outros! Deixe seus comentários e sugestões.

brazilsalesforceeffectiveness@gmail.com

VBA Intermediário - Função que converte um Range numa String separada por [Enter] - Convert my Range Array to Single Cell String

VBA Intermediário - Função que converte um Range numa String separada por [Enter] - VBA - Convert my Range Array to Single Cell String

​

Vez ou outra precisaremos converter os conteúdos em um Range, dentro de uma célula. A função abaixo além de fazer isso, propicia que o intervalo entre os conteúdos do Range sejam separados por um [Enter], permitindo a apresentação dentro da célula sem perder o aspecto de coluna. Claro que essa característica poderá ser mudada para: Vírgula, barra, hífen, etc...

Function ConvertRngInStr (MyRange As Range)

    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardess@gmail.com

    '        Date: 20/07/2016 - 09:05

    ' Application: Field Force Dashboard Analysis®

    '     Purpose: Função que converte um Range numa String separada por [Enter] - Convert my Range Array to Single Cell String.

    

    Dim nFrase As String

Dim r As Range

     

    For Each r In MyRange

        Let nFrase = nFrase & r.Value & vbCrLf

    Next r

    

    Let ConvertRngInStr = nFrase

End Function

Se gostou, compartilhe este post com outros! Deixe seus comentários e sugestões.

brazilsalesforceeffectiveness@gmail.com

VBA Intermediário - Função Converte um Range num Array - Range to Array - Function ConRngArray

VBA Intermediário - Função Converte um Range num Array - Range to Array  - Function ConRngArray

​

O que segue abaixo é o exemplo de uma função que permite converter o intervalo contido num Range num Array.

Function ConRngArray (ByVal nRng As Range) As String()

        '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardess@gmail.com

    '        Date: 20/07/2016 - 07:03

    ' Application: Field Force Dashboard Analysis®

    '     Purpose: Função Converte um Range num Array - Range to Array

Dim nVector01 As Variant

Dim nVector02() As String

Dim i As Long

Let nVector01 = nRng.Value

ReDim nVector02(1 To UBound(nVector01))

For i = 1 To UBound(nVector01)

    Let nVector02(i) = nVector01(i, 1)

Next

Let ConRngArray = nVector02()

End Function n

Se gostou, compartilhe este post com outros! Deixe seus comentários e sugestões.

brazilsalesforceeffectiveness@gmail.com

TUDO EM PLANILHAS EXCEL!

TUDO EM PLANILHAS EXCEL! 

Ampla familiaridade

MELHORE SUAS PLANILHAS

- Torne-as mais rápidas

- Propicie backups automáticos

- Acrescente macros produtivas

- Organize-as automaticamente

DASHBOARDS

- Impacte com Dashboards

- Transforme seus conteúdos

- Dê atenção para o conteúdo

Solicite orçamento via:

brazilsalesforceeffectiveness@gmail.com

MELHORE SEUS BANCOS DE DADOS E APLICAÇÕES MS ACCESS

MELHORE SUAS APLICAÇÕES MS ACCESS

Ampla familiaridade

MELHORE SEUS BANCOS DE DADOS E APLICAÇÕES MS ACCESS

Desenvolvemos quaisquer soluções e aplicações pessoais ou da empresa comnossa consultoria freelance.

Conecte TODAS as suas bases de dados

Melhore cada aplicação existente

Atualize a versão MS Access da sua aplicação

Implemente uma versão mais afinada à sua necessidade

Melhore os relatórios e as interfaces

Conecte suas aplicações as planilhas

Solicite orçamento via:

brazilsalesforceeffectiveness@gmail.com

VBA Excel Intermediário - Exportando DOIS Ranges Simultaneamente para o PowerPoint

VBA Excel Intermediário - Exportando DOIS Ranges Simultaneamente para o PowerPoint

Sim, caso nosso Dashboard seja grande demais, ou tenha pequenas partes que gostaria de destacar durante a sua apresentação, talvez decida exportar pequenas partes em slides separados, logo após tê-los exportado juntos.

Ter a liberdade de poder efetuar essa exportação com a mesma funcionalidade técnica é sempre uma bem recebida solução para a nossa correria do dia a dia.

Um plus+ neste código é o que verá no arremate da colagem da imagem, quando o script tenta adequar o tamanho da imagem ao slide onde está sendo colado. 

Começa assim:

    Dim nTitle As String
    Dim nRngName01 As String

    Dim nRngName02 As String

     Let nRngName01 = "TOP"
     Let nRngName02 = "BODY"

     Let nTitle = ActiveSheet.Range("AB9").Value

    Call XPortRng2PPT (nRngName01, nRngName02, nSheetName, nTitle)

Continue assim:

Sub XPortRng2PPT (nRngName01 As String, nRngName02 As String, nSheet As String, nTitle As String)
    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardes@gmail.com
    '        Date: 01/06/2016 - 10:32
    ' Application: Field Force Dashboard Analysis® 
    '     Purpose: Copy/Paste An Excel Range Into a New PowerPoint Presentation

    Dim ActFileName As Variant
    Dim ScaleFactor As Single

    On Error GoTo ErrorHandling

    Let ActFileName = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.pptx), *.ppt")
    Let ScaleFactor = Range("myScaleFactor").Value

    Application.Sheets(nSheet).Select

    Set PP = CreateObject("Powerpoint.Application")

    If ActFileName = False Then
        PP.Activate
        PP.Presentations.Add
        Set PP_File = PP.ActivePresentation
    Else
        PP.Activate
        Set PP_File = PP.Presentations.Open(ActFileName)
    End If

    Let PP.Visible = True

    CopyandPastetoPPT nRngName01, nTitle, ScaleFactor, ScaleFactor
    CopyandPastetoPPT nRngName02, nTitle, ScaleFactor, ScaleFactor

    Set PP_Slide = Nothing
    Set PP_File = Nothing
    Set PP = Nothing

    Application.Sheets(nSheet).Activate
Exit Sub

ErrorHandling:

Set PP_Slide = Nothing
Set PP_File = Nothing
Set PP = Nothing

MsgBox "Error No.: " & Err.Number & vbNewLine & vbNewLine & "Description: " & Err.Description, vbCritical, "Error"

End Sub

Sub CopyandPastetoPPT (myRangeName As String, _
                              myTitle As String, _
                              myScaleHeight As Single, _
                              myScaleWidth As Single)
    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardes@gmail.com
    '        Date: 01/06/2016 - 10:32
    ' Application: Field Force Dashboard Analysis®
    '     Purpose: Copy/Paste.

    Dim NextShape As Integer

    Application.GoTo Reference:=myRangeName

    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    Range("A1").Select

    PP.ActivePresentation.Slides.Add PP.ActivePresentation.Slides.Count + 1, 11

    Set PP_Slide = PP_File.Slides(PP.ActivePresentation.Slides.Count)
    Let PP_Slide.Shapes.Title.TextFrame.TextRange.Text = myTitle
    Let NextShape = PP_Slide.Shapes.Count + 1

    PP_Slide.Shapes.PasteSpecial 2
    
    PP_Slide.Shapes(NextShape).ScaleHeight myScaleHeight, 1
    PP_Slide.Shapes(NextShape).ScaleWidth myScaleWidth, 1
    PP_Slide.Shapes(NextShape).Left = PP_File.PageSetup.SlideWidth \ 2 - PP_Slide.Shapes(NextShape).Width \ 2
    PP_Slide.Shapes(NextShape).Top = 90

End Sub


Se gostou, compartilhe este post com outros! Deixe seus comentários e sugestões.

brazilsalesforceeffectiveness@gmail.com

VBA Excel Intermediário - Exportando um Range para o PowerPoint

VBA Excel Intermediário - Exportando um Range para o PowerPoint

Exportar um range específico do nosso Dashboard diretamente para o MS Powerpoint deixou de ser um grande segredo e tornou-se a funcionalidade mais usada entre aqueles que conhecem um pouco de VBA. Por isso disponibilizo mais uma versão dessa possibilidade:

Sub ExcelRangeToPowerPoint(nSheet As String, NewPPT As Boolean, nRng As String, nLeft As Integer, nTop As Integer)
    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardes@gmail.com
    '        Date: 11/05/2016 - 12:25
    ' Application: Field Force Dashboard Analysis®
    '     Purpose: Copy/Paste An Excel Range Into a New PowerPoint Presentation

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object

'Copy Range from Excel
  Set rng = Sheets(nSheet).Range(nRng) 'ThisWorkbook.ActiveSheet.Range(nRng)

'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint não pôde ser aberto, abortando exportação."
        Exit Sub
      End If

  On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False

'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly

'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  
    'Set position:
      myShape.Left = nLeft
      myShape.Top = nTop

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub



Se gostou, compartilhe este post com outros! Deixe seus comentários e sugestões.

brazilsalesforceeffectiveness@gmail.com

VBA Excel Intermediário - Como Desligar os Menus do MS Excel, Maximizando a Visualização do Dashboard? - Hide/Show Ribbon Programmaticaly

VBA Excel Intermediário - Como Desligar os Menus do MS Excel, Maximizando a Visualização do Dashboard?

Hide/Show Ribbon Programmaticaly

Ás vezes nossos Dashboards são enormes e desejamos que sejam mostrados em sua totalidade, por vezes, ocupando toda a tela. 

De fato, a visualização pode ficar fantástica, mas não queremos que ela seja prejudicada pelos menus padrões do MS Excel não é mesmo? Então, Como Desligar os Menus do MS Excel, Maximizando a Visualização do um Dashboard?

Use este código, que pode ser acionado através de um botão ou mesmo logo que o seu Dashboard for aberto:

Private Sub btnMenu01_Click()
    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardes@gmail.com
    '        Date: 23/06/2016 - 09:33; 20/06/2016 - 08:08
    ' Application: Field Force Dashboard Analysis® - © ALLERGAN 2016, Inc. Todos os direitos reservados.
    '     Purpose: Load / Unload Main Menu.

    Dim nStat As Boolean
    Dim nLbl As String
    Dim nToolBarStr As String

    Let Application.ScreenUpdating = False

    ' Posiciona na Planilha.

    ActiveSheet.Select
    ActiveSheet.Activate

    If btnMenu01.Value Then
        Let nToolBarStr = "Show.ToolBar(""Ribbon"", False)"
        Let nStat = False
        'Let ActiveWindow.Zoom = 55

        ' Opções.
        Application.ExecuteExcel4Macro nToolBarStr

        Let Application.DisplayFormulaBar = nStat
        Let ActiveWindow.DisplayWorkbookTabs = nStat

        Range("A1").Select

        ' Mostra o Form.
        MainMenuFRM.Show (0)  ' 21.06.16
    Else
        Let nToolBarStr = "Show.ToolBar(""Ribbon"", True)"
        Let nStat = True
        'Let ActiveWindow.Zoom = 70

        ' Opções.
        Application.ExecuteExcel4Macro nToolBarStr

        Let Application.DisplayFormulaBar = nStat
        Let ActiveWindow.DisplayWorkbookTabs = nStat

        ActiveSheet.Range("A1").Select

        ' Esconde o Form.
        MainMenuFRM.Hide
    End If

    Let Application.ScreenUpdating = True

End Sub


Outra opção seria, simplesmente:

Sub HideRibbon()    Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"
End Sub 

Sub ShowRibbon()    Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
End Sub

Somente nas versões do MS Excel 2010-2016 você poderá usar o comando: CommandBars.ExecuteMso "MinimizeRibbon"

Nestas versões também pdoerá checar o estado do Ribbon.

Sub test()

If RibbonState = 0 Then CommandBars.ExecuteMso "MinimizeRibbon"

End Sub 

Function RibbonState() As Long

'Result: 0=normal, -1=autohide

Let RibbonState = (CommandBars("Ribbon").Controls(1).Height < 100)

End Function

brazilsalesforceeffectiveness@gmail.com