Views

...

Important:

Quaisquer soluções e/ou desenvolvimento de aplicações pessoais, ou da empresa, que não constem neste Blog podem ser tratados como consultoria freelance.

E-mails

Deixe seu e-mail para receber atualizações...

eBook Promo

VBA Excel - Ordena worksheets da planilha - Sort All Sheets in a Workbook

Inline image 1

Podemos ordenar todas as Sheets duma seqüência alfabética.
Sub SrtShs()
Dim iSheet As Long, iBefore As Long 
For iSheet = 1 To ActiveWorkbook.Sheets.Count     
    Let Sheets(iSheet).Visible = True 
    For iBefore = 1 To iSheet - 1       
        If UCase(Sheets(iBefore).Name) & UCase(Sheets(iSheet).Name) Then  
                      ActiveWorkbook.Sheets(iSheet).Move 
          Before:=ActiveWorkbook.Sheets(iBefore)         
          Exit For       
        End If     
    Next iBefore   
Next iSheet 
End Sub
  
  

Reference:

Inspiration:

TagsVBA, Excel, wrap, sheet, sheets, ws, insert, sort, ordena


VBA Excel - Loop por todas as worksheets

Sim, ter a capacidade de passar por todas as planilhas do Workbook é simples, mas necessário.

Talvez precise proteger, configurar, encriptar, estabelecer privilégios ou mesmo atualizar tabelas em todas as Sheets. Essa SUB lhe permitirá isso:

  Sub SheetsWrap()
    Dim iSheet as Long

    Let Application.ScreenUpdating = False

    For iSheet = 1 To ActiveWorkbook.WorkSheets.Count

          Let WorkSheets(iSheet).cells(1,1) = "'" & WorkSheets(iSheet).name

    Next iSheet

    Let Application.ScreenUpdating = True
  End Sub

Reference:

Inspiration:

TagsVBA, Excel, loop, laço, wrap, sheet, sheets, ws


VBA Excel - Automatizando anotações recorrentes - Automate recurring appointments on MS Outlook

Inline image 1

Este código serve para automatizarmos certas anotações que desejamos fiquem registradas para nossas lembranças posteriores. Isso pode ser feito dentro do MS Outlook, mas também pode ser executado fora dele em outras instancias.


Let strExcelPath = ""

Const olAppointmentItem = 1
Const olRecursWeekly = 1

Set objExcel = CreateObject("Excel.Application") 

objExcel.WorkBooks.Open strExcelPath

Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)

Let intRow = 3

Do While objSheet.Cells(intRow, 1).Value <> ""
    Let strName = objSheet.Cells(intRow, 3).Value
    Let strDate = objSheet.Cells(intRow, 4).Value
    
    Set objOutlook = CreateObject("Outlook.Application")
    Set objAppointment = objOutlook.CreateItem(olAppointmentItem)

    Let strStart = strDate & "/2013 11:00 AM"
    Let strEnd = strDate & "/2099 11:00 AM"
    Let objAppointment.Start = strStart
    Let objAppointment.Duration = 30
    Let objAppointment.Subject = strName & " Event"
    Let objAppointment.Body = "Lembre-se, hoje você tem compromisso com " &strName& "' - Reunião de ..."
    Let objAppointment.Location = "Triumph Circle"
    Let objAppointment.ReminderMinutesBeforeStart = 15
    Let objAppointment.ReminderSet = True

    Set objRecurrence = objAppointment.GetRecurrencePattern
    Let objRecurrence.RecurrenceType = 5
    Let objRecurrence.PatternStartDate = strStart
    Let objRecurrence.PatternEndDate = strEnd

    objAppointment.Save
    
    Set objRecurrence = nothing
    Set objAppointment = nothing
    Set objOutlook = nothing
  
    Let intRow = intRow + 1
Loop

' Close workbook and quit Excel.
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit

set objSheet = nothing
set objExcel = nothing

Reference:

Aditya Kalra

Inspiration:
André Luiz Bernardes

TagsVBA, Excel, Outlook, automation, automate, appointment, 

VBA Excel - Convertendo planilha Excel para arquivo texto - Convert Excel to Text file

Inline image 1

Parece não haver por aí muitos códigos que demonstram como converter o conteúdo de planilhas em arquivos texto. Pelo menos não de forma reutilizável. Espero que este possa ajudar a muitos, especialmente os neófitos.

'Prompts for accepting user input
Let strViewPath = Trim (InputBox ("PLANILHA - Por favor, digite o path do arquivo",,"C:\Bernardes\"))
Let strTest = Trim (InputBox ("TEXTO - Por favor, digite o arquivo texo",,"sample"))
       
If Right (strViewPath, 1) <> "\" Then
   Let strViewPath = strViewPath & "\"   
End If       

Let strTestName = strTest
Let strTextFilePath = strViewPath
   
'Assign the values for the excel and text file that needs to be converted
Let TestToConvert = strViewPath + strTest + ".xls"
Let TextFile =strTextFilePath  + strTestName + ".txt"
   
'Create the excel object
Set oExcel = CreateObject("Excel.Application")
Let oExcel.Visible = False

'Open the excel file for conversion
Let oExcel.DisplayAlerts = False
oExcel.Workbooks.Open TestToConvert, True
'Call the text streamer function that will convert the file
TextStreamer TextFile, oExcel
 
'Exit the Excel file
oExcel.Quit

Private Sub TextStreamer(TextFileName, objExcel)

'Declare constants for reading,writing and appending to a text file
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
   
Dim fs, f, ts, x, y, LastRow, LastColumn, c, objSheet, shts()
'Create the file system object for text file editing
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateTextFile TextFileName
       
Set f = fs.GetFile(TextFileName)
Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)
   
'Get the number of worksheets in the source excel file
Let intNoOfSheets = objExcel.Worksheets.count
Let z = intNoOfSheets
   
'Traverse through every sheet that needs to be converted
For i = 1 to intNoOfSheets
       
 'Activate the first worksheet
    objExcel.Worksheets(z).Activate
    objExcel.Worksheets(z).Select
    Set objSheet = objExcel.ActiveWorkbook.Worksheets(z)
    
    Let strSheetName = objsheet.name
    objSheet.Cells(1).Select

    Let LastRow = objSheet.UsedRange.Rows.Count + 2
    Let LastColumn = objSheet.UsedRange.Columns.Count   
                   
    objSheet.Cells(1).Select
                   
    ts.write "["&strSheetName&"]"
    ts.write Chr(13) & Chr(10)
           
    'Loop through the rows and columns in the excel worksheet and write the data to the text file       

    For x = 0 To LastRow
        For y = 0 To LastColumn -1
            If objExcel.ActiveCell.Offset(x, y).Value <> "" then
                ts.write (objExcel.ActiveCell.Offset(x, y).Value)
                'ts.write Chr(9)   
            End If
        Next
        ts.write Chr(13) & Chr(10)
    Next               
  
Let z= z-1

Next
       
'Close the excel file test streamer
ts.Close
msgbox "Conversion Complete!"
End Sub

Reference:
Aditya Kalra
Inspiration:

TagsVBA, Excel, convert, text, to text, planilha, sheet, worksheet, 

VBA Excel - Juntando distintas planilhas - Combine worksheets in Excel and Kill all excel objects

Inline image 1

Quando estamos trabalhando com várias planilhas, não raramente centenas delas, e precisamos elaborar uma análise, um relatório, importá-las para uma base de dados, etc...Tudo isso seria mais fácil se ao invés de termos centenas de arquivos, tivéssemos acesso a somente uma planilha contendo os dados de todas as demais. Sim, meus caros, nos pouparia muito tempo. E como sempre nos vem a pergunta: Como?

Segue:

Sub CopyFromWorksheets()
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range
Dim colCount As Long
'Dim sheetDelimiter As String
' Creates excel app object
Set objExcel = CreateObject("Excel.Application")
   
' Makes the excel invisible
objExcel.Visible = False
' Supress all display alerts
objExcel.DisplayAlerts = False
' Gets the complete path of the active excel sheet
strExcelFilePath = ActiveWorkbook.FullName
  
' Opens the excel file
Set objWorkbook = objExcel.Workbooks.Open(Trim(strExcelFilePath))

Set objWorkSheet = objWorkbook.Worksheets("Merge")
objWorkSheet.Activate
' Gets the count of column
Set objRange = objWorkbook.Worksheets("Merge")
numRowsCount = objRange.Evaluate("COUNTA(A1:A100)")
Worksheets("Merge").Activate
'sheetDelimiter = "######"
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Consolidated Backlog" Then
MsgBox "There is a worksheet called as 'Consolidated Backlog'." & vbCrLf & _
"Please remove or rename this worksheet since 'Consolidated Backlog' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
Application.ScreenUpdating = False
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
trg.Name = "Consolidated Backlog"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = 30

For cntLoop = 1 To numRowsCount
     strSheetName = Trim(UCase(objExcel.Cells(cntLoop, 1).Value))
     If Trim(strSheetName) = "" Then
        Exit For
     End If
     If Trim(strSheetName) = "SHEET NAMES" Then
       GoTo Continue
     End If
     For Each sht In wrk.Worksheets
        'If worksheet in loop is the last one, stop execution (it is Master worksheet)
        If sht.Index = wrk.Worksheets.Count Then Exit For
        If strSheetName = UCase(sht.Name) Then
            'Delimits the copied sheets with a string in a new row
            With trg.Cells(1, 1).Resize(1, colCount)
                .Value = sht.Cells(1, 1).Resize(1, colCount).Value
                 'Set font as bold
                .Font.Bold = True
            End With
            
            trg.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(1, 1).Value = sheetDelimiter
            Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(Rows.Count, 1).End(xlUp).Resize(, colCount))
            rng.Copy trg.Cells(Rows.Count, 1).End(xlUp).Offset(1)
            'Set objRange = sht.Range("A1").EntireColumn
            'objRange.Insert (xlShiftToRight)
            'sht.Range("A1") = sht.Name
        End If
    Next sht
Continue:
Next
objExcel.Quit
Set objWorkbook = Nothing
Set objExcel = Nothing
Set sht = Nothing
Set objWorkSheet = Nothing
Set objRange = Nothing
Set trg = Nothing
Set rng = Nothing
Application.ScreenUpdating = True
'create WMI object instance
Set objWMI = GetObject("winmgmts:")
If Not IsNull(objWMI) Then
'create object collection of Win32 processes
Set objProcList = objWMI.InstancesOf("win32_process")
For Each objProc In objProcList 'iterate through enumerated
If UCase(objProc.Name) = UCase(procName) Then
objProc.Terminate (0)
End If
Next
End If
Set objProcList = Nothing
Set objWMI = Nothing

End Sub

Reference:

Aditya Kalra

Inspiration:
André Luiz Bernardes

TagsVBA, Tips, dummy, dummies, row, last, cell, célula, dirty area, detect, detectar

VBA Excel - Exportando Gráficos, Tabelas, criando Dashboards

Inline image 1

Este artigo visa ampliar a qualidade das aplicações que desenvolvemos por lhes acrescentar uma característica bem desejável, que é a de: 

Enviar o conteúdo das nossas soluções para outros ambientes e interfaces 
Em todas as aplicações da suíte MS Office, a editores gráficos para a criação de Info Gráficos e até mesmo a inserção destes em páginas da Web de modo automatizado (Sharepoint).

Mas talvez esteja se perguntando: Prá que quero isso? Seguem-se diversos códigos bem elaborados que possibilitarão copiar os gráficos das suas planilhas pré-existentes, bem como os ranges de dados destas (conjuntos de células previamente selecionados) quais imagens. 

Detalho:
Por vezes desejará não enviar a fonte de dados junto com o gráfico para um Slide que lhe solicitaram.

Talvez deseje enviar uma tabela, um relatório, partes de um Balanced Scorecard, um Dashboards ou um  Scorecards, ou mesmo um conjunto de KPIs, sem que estes sejam alterados por quem recebê-los.

Criar um informativo regular, parte de um relatório, que envia via MS Outlook, comentários dos
relatórios, agregando conteúdo analítico e não apenas gráficos e dados estáticos para o público alvo.

Como fazê-lo?
Com os recursos abaixo alistados, poderá enviar somente as imagens, como se tirasse uma foto e colasse no Slide, ou num documento do MS Word, no corpo do email e até mesmo no Photoshop (há!).

Chega! Essas são apenas algumas das possibilidades...Pensem em outras...

CÓDIGO: 
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture

Para copiar um gráfico selecionado (ou ativo) em uma planilha, implemente a seguinte sintaxe:


CÓDIGO: 
ActiveChart.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Copiando um range de dados, colando-a como uma imagem:

CÓDIGO: 
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Copie gráficos selecionados (ou ativo) em uma planilha, implemente a seguinte sintaxe:

CÓDIGO: 
Worksheets("Nome da pasta").ChartObjects(1).Chart.CopyPictureAppearance:=xlScreen, Size:=xlScreen, Format:=xlPicture

Copie uma faixa de dados específica, embora não esteja selecionada, colando-a a posteriori:
:

CÓDIGO: 
Worksheets("Nome da pasta").Range("B11:AF25").CopyPicture Appearance:=xlScreen, Format:=xlPicture

Pois é, sempre existem códigos admiráveis por aí:


CÓDIGO:
Sub GraficoToPowerPoint()
    Dim objPPT As Object
    Dim objPrs As Object
    Dim shtTemp As Worksheet
    Dim chtTemp As ChartObject
    Dim intSlide As Integer
     
    Set objPPT = CreateObject("Powerpoint.application")
    objPPT.Visible = True
    objPPT.presentations.Open ThisWorkbook.Path & "\Dashboard_Bernardes.ppt"
    objPPT.ActiveWindow.ViewType = 1 'ppViewSlide
     
    For Each shtTemp In ThisWorkbook.Worksheets
        For Each chtTemp In shtTemp.ChartObjects
            intSlide = intSlide + 1
            chtTemp.CopyPicture
            If intSlide > objPPT.presentations(1).Slides.Count Then
                objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.presentations(1).Slides.Add(Index:=intSlide, Layout:=1).SlideIndex
            End If
            objPPT.ActiveWindow.View.Paste
        Next
    Next
    objPPT.presentations(1).Save
    objPPT.Quit
     
    Set objPrs = Nothing
    Set objPPT = Nothing
End Sub

Copiando range e gráfico para o MS Powerpoint:

CÓDIGO:
Sub GraficoRange_TO_Powerpoint() 
    Dim objPPT As Object 
    Dim objPrs As Object 
    Dim objSld As Object 
    Dim shtTemp As Object 
    Dim chtTemp As ChartObject 
    Dim objShape As Shape 
    Dim objGShape As Shape 
    Dim intSlide As Integer 
    Dim blnCopy As Boolean 
     
    Set objPPT = CreateObject("Powerpoint.application") 
    objPPT.Visible = True 
    objPPT.Presentations.Add 
    objPPT.ActiveWindow.ViewType = 1
     
    For Each shtTemp In ThisWorkbook.Sheets 
        blnCopy = False 
        If shtTemp.Type = xlWorksheet Then 
            For Each objShape In shtTemp.Shapes
                blnCopy = False 
                If objShape.Type = msoGroup Then 

                    For Each objGShape In objShape.GroupItems 
                        If objGShape.Type = msoChart Then 
                            blnCopy = True 
                            Exit For 
                        End If 
                    Next 
                End If 
                If objShape.Type = msoChart Then blnCopy = True 
                 
                If blnCopy Then 
                    intSlide = intSlide + 1 
                    objShape.CopyPicture 

                    objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
                    objPPT.ActiveWindow.View.Paste 
                End If 
            Next 
            If Not blnCopy Then 

                intSlide = intSlide + 1 
                shtTemp.UsedRange.CopyPicture 

                objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
                objPPT.ActiveWindow.View.Paste 
            End If 
        Else 
            intSlide = intSlide + 1 
            shtTemp.CopyPicture 

            objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
            objPPT.ActiveWindow.View.Paste 
        End If 
    Next 
     
    Set objPrs = Nothing 
    Set objPPT = Nothing 
End Sub

Bônus:

CÓDIGO: 
Sub RangeUsado_TO_Powerpoint()
    Dim objPPT As Object
    Dim shtTemp As Object
    Dim intSlide As Integer
     
    Set objPPT = CreateObject("Powerpoint.application")
    objPPT.Visible = True
    objPPT.Presentations.Open ThisWorkbook.Path & "\Bernardes.ppt"
    objPPT.ActiveWindow.ViewType = 1
    
    For Each shtTemp In ThisWorkbook.Sheets
        shtTemp.Range("A1", shtTemp.UsedRange).CopyPicture xlScreen, xlPicture
        intSlide = intSlide + 1

        objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex
        objPPT.ActiveWindow.View.Paste
        With objPPT.ActiveWindow.View.Slide.Shapes(objPPT.ActiveWindow.View.Slide.Shapes.Count)
            .Left = (.Parent.Parent.SlideMaster.Width - .Width) / 2
        End With
    Next
     
    Set objPPT = Nothing
End Sub


Boa diversão!

André Luiz Bernardes

TagsVBA, Excel, copy, object, objeto, copiar, chart, gráfico, object, chart, Dashboard, Scorecard

VBA - Brasil, O amadurecimento do nosso legado - Brazil, VBA Development reflections

Inline image 1

Quando criei este Blog específico de VBA, a inter-colaboração de códigos VBA inexistia no mercado nacional, ou era muito incipiente. A utilização profissional de Dashboards e Scorecards existia somente como a cópia e adaptação de modestos extravagantes modelos vindos de fora do Brasil, através das corporações que mantinham filiais por aqui. Nestas versões 'traduzidas' dentro dos ambientes corporativos tentava-se espelhar em tais modelos, as informações da filial brasileira ou fazíamos aqui a consolidação da América Latina.

O desenvolvimento VBA naquela época restringia-se as expressão "faz-se macros no excel'. 

Agora em 2012, vivenciamos um mercado de desenvolvimento VBA maduro, cheio de profissionais experientes, Blogs competentíssimos, inúmeras excelentes soluções de desenvolvimento e aplicações de automação disponíveis para várias pessoas baixarem e usarem. 

O mercado nacional está amadurecido e pronto para colaborar com o mercado internacional. Criando soluções e enviado-as as matrizes das empresas.

TagsVBA, Brasil, Brazil, Mercado, VBA Development

VBA Excel - Caixa de Diálogo - Dialog Box

Inline image 1

Sim, e porque não voltar ao básico? Perfect! 
Revemos o princípio e melhoramos o presente com excelentes perspectivas para o futuro.

Pronto para COPIAR e COLAR - Abra a caixa de diálogo e escolha o arquivo que desejar para o propósito que preferir. 

Primeira opção

Não é raro precisarmos pedir alguma informação para o usuário. Qual a melhor maneira de fazer isso se não usar uma caixa de diálogo?

Sub UserInput()

Dim iReply As Integer

    iReply = MsgBox(Prompt:="Do you wish to run the 'update' Macro", _
            Buttons:=vbYesNoCancel, Title:="UPDATE MACRO")
            
    If iReply = vbYes Then

        Run "UpdateMacro"

    ElseIf iReply = vbNo Then

       'Do Other Stuff

    Else 'They cancelled (VbCancel)

        Exit Sub

    End If

End Sub 

Segunda opção
InputBox(prompt[, title] [, default] [, xpos] [, ypos] [, helpfile, context])
Agora suponhamos que você queira submeter os dados entrados a uma análise prévia e direcionamento...Ahhh, isso seria interessante não é mesmo? Tente isso:

Sub GetUserName()

Dim strName As String


    strName = InputBox(Prompt:="Seu nome,por favor.", _
          Title:="Digite o seu Nome", Default:="Digite seu nome aqui")
          

        If strName = " Digite seu nome aqui " Or _
           strName = vbNullString Then

           Exit Sub

        Else

          Select Case strName

            Case "André"

                'Faça as coisas para o perfil André

            Case "Luiz"

                'Faça as coisas para o perfil Luiz

            Case "Bernardes"

                'Faça as coisas para o perfil Bernardes

            Case Else

                'Faça as coisas para uns perfis mais genéricos 

          End Select

        End If

End Sub


Terceira opção

Dim strFilePath As String, strPath As String
Dim fdgO As FileDialog, varSel As Variant

MsgBox "A tabela não está correta, " &
_
"e o arquivo de dados não pôde ser achado na respectiva pasta: " & _
strPath & ". Por favor,localize a pasta que contenha dados de exemplo " & _
".: Dialog.", vbInformation, gstrAppTitle

Set fdgO = Application.FileDialog(msoFileDialogFilePicker)
With fdgO

.AllowMultiSelect = False

.Title = "Localize a pasta com dados de exemplo"

.ButtonName = "Escolha"

.Filters.Clear

.Filters.Add "All Files", "*.*", 1

.FilterIndex = 1

.InitialFileName = strPath

.InitialView = msoFileDialogViewDetails

If .Show = 0 Then
MsgBox "Houve falha para selecionar o arquivo correto. ATENÇÃO: " & _
"Você talvez não tenha aberto uma tabela conectada a aplicação. " & _
" Você pode re-abrir este formulário ou " & _
"inicie o formulário, tentando novamente.", vbCritical,
gstrAppTitle

Let CheckConnect = False

Exit Function
End If

Let strFilePath = .SelectedItems(1)
End With

Let strPath = Left(strFilePath, InStrRev(strFilePath, "\") - 1)
Let varSel = AttachAgain(strPath)

Quarta opção

Sub GetDat () 
      ' Posiciona num local  específico.
      ChDrive "C: \" 
      ChDir "C: \ Teste \" 

      Let FileToOpen = Application.GetOpenFilename _
      (Title:="Por favor escolha o arquivo a importar:", FileFilter:="Arquivos Excel *.xls (*.xls),")''

      If FileToOpen = False Then

            MsgBox "Arquivo não especificado!", vbExclamation, ":. A&A"

            Exit Sub
      Else
            Workbooks.Open Filename:=FileToOpen
      End If
End Sub

André Luiz Bernardes

TagsVBA, Dialog box, message, mensagem, caixa de diálogo

eBooks VBA na AMAZOM.com.br

LinkWithinBrazilVBAExcelSpecialist

Related Posts Plugin for WordPress, Blogger...

Vitrine