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

| Blog Office VBA | Blog Excel | Blog Access | 

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:

Tags: VBA, Excel, wrap, sheet, sheets, ws, insert, sort, ordena

VBA Excel - Loop por todas as worksheets

| Blog Office VBA | Blog Excel | Blog Access | 

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:

Tags: VBA, Excel, loop, laço, wrap, sheet, sheets, ws

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

| Blog Office VBA | Blog Excel | Blog Access |

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

Tags: VBA, Excel, Outlook, automation, automate, appointment, 

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

| Blog Office VBA | Blog Excel | Blog Access |

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:

Tags: VBA, Excel, convert, text, to text, planilha, sheet, worksheet, 

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

| Blog Office VBA | Blog Excel | Blog Access |

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

Tags: VBA, Tips, dummy, dummies, row, last, cell, célula, dirty area, detect, detectar

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

| Blog Office VBA | Blog Excel | Blog Access |

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!

Reference:

VBA POWERPOINT: Atualizando gráfico com dados do MS Excel

Copy Charts To Powerpoint Slides (charts As Sheets)‎
Charts to PowerPoint‎
Copy Chart And Table To Powerpoint‎
export Excel chart to powerpoint‎ 

Inspiration:

André Luiz Bernardes

Tags: VBA, Excel, copy, object, objeto, copiar, chart, gráfico, object, chart, Dashboard, Scorecard

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

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.

Tags: VBA, Brasil, Brazil, Mercado, VBA Development

VBA Excel - Caixa de Diálogo - Dialog Box

| Blog Office VBA | Blog Excel | Blog Access | 

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


Reference:

• 
  Windows

  
  Office

  
  Windows Phone

  
  Xbox

  
  Skype

  
  Bing

Inspiration:

André Luiz Bernardes

Tags: VBA, Dialog box, message, mensagem, caixa de diálogo