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 - Identificando a última Linha / Deletando Linhas e Colunas

Manipulando as linhas e colunas

Conditionally Deleting Rows
Delete Cells/Rows in Range, based on empty cells
Delete Empty Rows
Delete Excel Rows Based on a Specified Condition or Criteria
Delete Row if a specific value exist
Delete Row if cell contains
Delete Row in a range
Delete Rows In Excel
Delete Rows and columns using VBA in Microsoft Excel
Delete entire ROW if a cell contains a phrase
Deleting Empty Rows
Deleting Rows
Excel Automatically Delete Rows that contain a certain word
Excel VBA Blank row deletion in Excel using methods other than loops
Excel blank row deletion?
How To Delete Rows
Macro for deleting Row with condition
Macro to delete Rows in excel?
Macro to remove blank cells
Remove Blank Rows
VBA Delete Entire Row if Contains Certain Text
VBA Delete Excel Rows Based on Certain Date

Entre todas as técnicas de VBA, esta é uma das melhores. já tive a oportunidade de disponibilizar aqui outros modos de como identificar qual é a última linha (ou o último registro) numa planilha de dados. Para ser breve e suscinto, as outras técnicas volta e meia eram falhas devido a "dirty area". Depois de algum tempo alguns programadores acharam a melhor técnica para identificarmos a última ocorrência sem falhas. O exemplo abaixo é uma variante da técnica ensinada pelo Excel MVP, Bob Umlas. Testem naquelas bases de dados mais "parrudas", com grandes quantidades de dados, acima de 100.000 linhas e vejam o excelente resultado.
CÓDIGO:
Function LCell(ws As Worksheet) As Range Dim LRow&, LCol% On Error Resume Next With ws Let LRow& = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Let LCol% = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column End With Set LCell = ws.Cells(LRow&, LCol%) End Function
Usando esta função: A função LCell demonstrada aqui não poderá ser utilizada diretamente em uma planilha, mas poderá ser evocada a partir de outro procedimento VBA. Implemente o código como abaixo:
CÓDIGO:
Sub Identifica() MsgBox LCell(Sheet1).Row End Sub

Outra contribuição interessante é essa cuja a função retorna diretamente o número da última linha, inclusive para uma célula de planilha, contribuição do Adilson Soledade no Fórum da Info, num tópico que iniciei por lá:
CÓDIGO:
Function LRow(Ref As Range) As Integer Dim ws As Worksheet On Error Resume Next Set ws = Ref.Parent LRow = ws.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row End Function

Muitas e muitas vezes, vejo postado neste e em outros diversos fóruns ao redor do mundo e na WEB 2.0, pessoas pedindo uma macro para excluir todas as linhas em branco ou todas as linhas duplicadas de uma série de linhas em uma planilha. Aqui tem três códigos: Bernardes_DeleteBlankRows, Bernardes_DeleteRowOnCell, e Bernardes_DeleteDuplicateRows, que fazem isso.
Lembre-se, estas macros apagam linhas inteiras de sua planilha, não excluem células individuais.

Excluindo linhas em branco O código Bernardes_DeleteBlankRows descrito a seguir irá apagar todas as linhas em branco na planilha especificada pela WorksheetName parâmetro. Se este parâmetro for omitido, a planilha ativa será utilizada. O procedimento apagará as linhas que estiverem totalmente em branco ou contiverem células cujo o conteúdo seja apenas um único apóstrofe (caracter que controla a formatação). O procedimento exige a função IsRowClear, mostrada após o procedimento Bernardes_DeleteBlankRows. Não apagará as linhas que contém fórmulas, mesmo que a fórmula retorne um valor vazio. A função não excluirá as linhas precedentes de uma fórmula em uma célula se as linhas precedentes tiverem menor número de linhas que a linha. No entanto, se uma fórmula referir-se a uma série de linhas com números mais altos do que as células que contém a fórmula, e as linhas forem totalmente em branco, as linhas referenciadas pela fórmula serão excluídas. Portanto, a referência da fórmula pode ser alterada nas linhas acima da fórmula excluída.
CÓDIGO:
Sub Bernardes_DeleteBlankRows(Optional WorksheetName As Variant) ' This function will delete all blank rows on the worksheet ' named by WorksheetName. This will delete rows that are ' completely blank (every cell = vbNullString) or that have ' cells that contain only an apostrophe (special Text control ' character). ' The code will look at each cell that contains a formula, ' then look at the precedents of that formula, and will not ' delete rows that are a precedent to a formula. This will ' prevent deleting precedents of a formula where those ' precedents are in lower numbered rows than the formula ' (e.g., formula in A10 references A1:A5). If a formula ' references cell that are below (higher row number) the ' last used row (e.g, formula in A10 reference A20:A30 and ' last used row is A15), the refences in the formula will ' be changed due to the deletion of rows above the formula. ' Dim RefColl As Collection Dim RowNum As Long Dim Prec As Range Dim Rng As Range Dim DeleteRange As Range Dim LastRow As Long Dim FormulaCells As Range Dim Test As Long Dim WS As Worksheet Dim PrecCell As Range If IsMissing(WorksheetName) = True Then Set WS = ActiveSheet Else On Error Resume Next Set WS = ActiveWorkbook.Worksheets(WorksheetName) If Err.Number <> 0 Then ''''''''''''''''''''''''''''''' ' Invalid worksheet name. ''''''''''''''''''''''''''''''' Exit Sub End If End If If Application.WorksheetFunction.CountA(WS.UsedRange.Cells) = 0 Then '''''''''''''''''''''''''''''' ' Worksheet is blank. Get Out. '''''''''''''''''''''''''''''' Exit Sub End If '''''''''''''''''''''''''''''''''''''' ' Find the last used cell on the ' worksheet. '''''''''''''''''''''''''''''''''''''' Set Rng = WS.Cells.Find(what:="*", after:=WS.Cells(WS.Rows.Count, WS.Columns.Count), lookat:=xlPart, _ searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=False) LastRow = Rng.Row Set RefColl = New Collection ''''''''''''''''''''''''''''''''''''' ' We go from bottom to top to keep ' the references intact, preventing ' #REF errors. ''''''''''''''''''''''''''''''''''''' For RowNum = LastRow To 1 Step -1 Set FormulaCells = Nothing If Application.WorksheetFunction.CountA(WS.Rows(RowNum)) = 0 Then '''''''''''''''''''''''''''''''''''' ' There are no non-blank cells in ' row R. See if R is in the RefColl ' reference Collection. If not, ' add row R to the DeleteRange. '''''''''''''''''''''''''''''''''''' On Error Resume Next Test = RefColl(CStr(RowNum)) If Err.Number <> 0 Then '''''''''''''''''''''''''' ' R is not in the RefColl ' collection. Add it to ' the DeleteRange variable. '''''''''''''''''''''''''' If DeleteRange Is Nothing Then Set DeleteRange = WS.Rows(RowNum) Else Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum)) End If Else '''''''''''''''''''''''''' ' R is in the collection. ' Do nothing. '''''''''''''''''''''''''' End If On Error GoTo 0 Err.Clear Else ''''''''''''''''''''''''''''''''''''' ' CountA > 0. Find the cells ' containing formula, and for ' each cell with a formula, find ' its precedents. Add the row number ' of each precedent to the RefColl ' collection. ''''''''''''''''''''''''''''''''''''' If IsRowClear(RowNum:=RowNum) = True Then ''''''''''''''''''''''''''''''''' ' Row contains nothing but blank ' cells or cells with only an ' apostrophe. Cells that contain ' only an apostrophe are counted ' by CountA, so we use IsRowClear ' to test for only apostrophes. ' Test if this row is in the ' RefColl collection. If it is ' not in the collection, add it ' to the DeleteRange. ''''''''''''''''''''''''''''''''' On Error Resume Next Test = RefColl(CStr(RowNum)) If Err.Number = 0 Then '''''''''''''''''''''''''''''''''''''' ' Row exists in RefColl. That means ' a formula is referencing this row. ' Do not delete the row. '''''''''''''''''''''''''''''''''''''' Else If DeleteRange Is Nothing Then Set DeleteRange = WS.Rows(RowNum) Else Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum)) End If End If Else On Error Resume Next Set FormulaCells = Nothing Set FormulaCells = WS.Rows(RowNum).SpecialCells(xlCellTypeFormulas) On Error GoTo 0 If FormulaCells Is Nothing Then ''''''''''''''''''''''''' ' No formulas found. Do ' nothing. ''''''''''''''''''''''''' Else ''''''''''''''''''''''''''''''''''''''''''''''''''' ' Formulas found. Loop through the formula ' cells, and for each cell, find its precedents ' and add the row number of each precedent cell ' to the RefColl collection. ''''''''''''''''''''''''''''''''''''''''''''''''''' On Error Resume Next For Each Rng In FormulaCells.Cells For Each Prec In Rng.Precedents.Cells RefColl.Add Item:=Prec.Row, key:=CStr(Prec.Row) Next Prec Next Rng On Error GoTo 0 End If End If End If ''''''''''''''''''''''''' ' Go to the next row, ' moving upwards. ''''''''''''''''''''''''' Next RowNum '''''''''''''''''''''''''''''''''''''''''' ' If we have rows to delete, delete them. '''''''''''''''''''''''''''''''''''''''''' If Not DeleteRange Is Nothing Then DeleteRange.EntireRow.Delete shift:=xlShiftUp End If End Sub Function IsRowClear(RowNum As Long) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''''' ' IsRowClear ' This procedure returns True if all the cells ' in the row specified by RowNum as empty or ' contains only a "'" character. It returns False ' if the row contains only data or formulas. '''''''''''''''''''''''''''''''''''''''''''''''''' Dim ColNdx As Long Dim Rng As Range ColNdx = 1 Set Rng = Cells(RowNum, ColNdx) Do Until ColNdx = Columns.Count If (Rng.HasFormula = True) Or (Rng.Value <> vbNullString) Then IsRowClear = False Exit Function End If Set Rng = Cells(RowNum, ColNdx).End(xlToRight) ColNdx = Rng.Column Loop IsRowClear = True End Function

Este código, Bernardes_DeleteBlankRows, excluirá uma linha, se toda a linha estiver em branco. Apagará a linha inteira se uma célula na coluna especificada estiver em branco. Somente a coluna marcada, outras são ignoradas.
CÓDIGO:
Public Sub Bernardes_DeleteRowOnCell() On Error Resume Next Selection.SpecialCells (xlCellTypeBlanks). EntireRow.Delete ActiveSheet.UsedRange End Sub

Para usar este código, selecione um intervalo de células por colunas e, em seguida, execute o código. Se a célula na coluna estiver em branco, a linha inteira será excluída. Para processar toda a coluna, clique no cabeçalho da coluna para selecionar a coluna inteira. Este código eliminará as linhas duplicadas em um intervalo. Para usar, selecione uma coluna como intervalo de células, que compreende o intervalo de linhas duplicadas a serem excluídas. Somente a coluna selecionada é usada para comparação.
CÓDIGO:
Sub Bernardes_DeleteDuplicateRows Pública () ''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''' 'DeleteDuplicateRows "Isto irá apagar registros duplicados, com base na coluna ativa. Ou seja, "se o mesmo valor é encontrado mais de uma vez na coluna activa, mas todos "os primeiros (linha número mais baixo) serão excluídos. " 'Para executar a macro, selecione a coluna inteira que você deseja escanear 'duplica e executar este procedimento. '''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''' R Dim As Long Dim N Long V Variant Dim Dim Rng Gama On Error GoTo EndMacro Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set Rng = Application.Intersect (ActiveSheet.UsedRange, _ ActiveSheet.Columns (ActiveCell.Column)) Application.StatusBar = "Processamento de Linha:" & Format (Rng.Row , "#,## 0 ") N = 0 para R = Rng.Rows.Count To 2 Step -1 Se Mod R 500 = 0 Then Application.StatusBar = "Linha de processamento:" & Format (R ", # # 0 ") End If = Rng.Cells (R, 1). Valor V '''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''' Nota "que COUNTIF obras estranhamente com uma variante que é igual a vbNullString. " Ao invés de passar na variante, você precisa passar vbNullString explicitamente. ''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''' Se V = vbNullString Então Se Application.WorksheetFunction. CONT.SE (Rng.Columns (1), vbNullString)> 1 Então Rng.Rows (R). EntireRow.Delete N = N + 1 End If Else Se Application.WorksheetFunction.CountIf (Rng.Columns (1), V)> 1 Então, (R). Rng.Rows EntireRow.Delete N = N + 1 End If End If Next R EndMacro: Application.StatusBar = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "Duplicar linhas excluídas:" & CStr (N ) End Sub

Fonte:
CPearson.com

Tags: André Luiz Bernardes, Analista, Programador VBA, MOS, Microsoft Office Specialist, VBA, Visual Basic for Applications, MS, Microsoft, Office, MS Office, Access 2010 MS Access, Excel 2010 MS Excel, Outlook 2010 MS Outlook, PowerPoint 2010 MS Powerpoint, Word 2010 MS Word, MS Visio, MS Communicator, OneNote 2010 MS OneNote, Publisher 2010 MS Publisher, InfoPath 2010 InfoPath, SharePoint Workspace 2010 SharePoint Workspace, Lync Lync,
Bob Umlas


A&A® - Work smart, not hard.

VBA 2011

Hello folks!

Sim, começou o ano, e a manutenção de antigos aplicativos, sistemas, macros e funcionalidades. Também abre-se-nos a perspectiva de criarmos novas ferramentas inovadoras. Talvez aplicarmos as técnicas que absorvemos, mas para a qual não tenha sobrado tempo para colocar em prática. Muitos hoje estão de fato produzindo excelentes resultados com o VBA - Visual Basic for Applications. Desenvolver-se como um Analista Programador VBA ou um MOS (Microsoft Office Specialist) é um desafio constante. Precisamos nos manter especialmente atualizados com o progresso na Web, nas Redes Sociais, com o Modelo de Negócio ao qual nos propusemos a atender. Além destes ainda fica a intrínseca necessidade de acompanharmos a evolução cada vez mais rápida e constante das linguagens já amadurecidas (C#, C++, Visual Basic, Kylix, etc...), bem como suas respectivas técnicas de programação. As arquiteturas de software também vêemo sendo ampliadas e re-organizadas (https://sites.google.com/site/vbabernardes/vba/microsoft_office_interactive_developer_map), afinal de contas os "Engenheiros de Software" não param de pirar, não é mesmo! Para os que já estão nisso a algum tempo, adicione-se a capacidade qual MMT (Master Management of the Time Gestor Mestre do tempo). Nossos projetos tornam-se maiores, mais complexos, envolvem mais pessoas e nos vemos sempre envoltos em reuniões (por vezes pouco produtivas e noutras extensivas ao excesso). Nesse momento nos percebemos distantes da codificação e envoltos no gerenciamento de equipes, grupos enormes e seus projetos ainda maiores. Mesmo em tais circunstâncias a atualização é necessária e imprescindível. Como atenuar tais desafios? Acredito na colaboração, no compartilhamento de códigos e técnicas (quando o tempo permite), na divulgação de bons Blogs (ahh, e na compra de analgésicos).
Fonte:

Tags: André Luiz Bernardes, Analista, Programador VBA, MOS, Microsoft Office Specialist, VBA, Visual Basic for Applications, MS, Microsoft, Office, MS Office, Access 2010 MS Access, Excel 2010 MS Excel, Outlook 2010 MS Outlook, PowerPoint 2010 MS Powerpoint, Word 2010 MS Word, MS Visio, MS Communicator, OneNote 2010 MS OneNote, Publisher 2010 MS Publisher, InfoPath 2010 InfoPath, SharePoint Workspace 2010 SharePoint Workspace, Lync Lync


A&A® - Work smart, not hard.

VBA Excel - Caixa de Diálogo

Olá mais uma vez...

Segue código pronto para o COPIAR e COLAR (do jeito que eu gosto). Abra a caixa de diálogo e escolha o arquivo que desejar para o propósito que preferir. E porque não voltar ao básico? Isso é perfeito! Revemos o princípio e melhoramos o presente com excelentes perspectivas para o futuro.


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


Segunda 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, "Duh!!!" Exit Sub Else Workbooks.Open Filename:=FileToOpen End If End Sub

Tags: André Luiz Bernardes, Analista, Programador VBA, MOS, Microsoft Office Specialist, VBA, Visual Basic for Applications, MS, Microsoft, Office, MS Office, Access 2010 MS Access, Excel 2010 MS Excel, Outlook 2010 MS Outlook, PowerPoint 2010 MS Powerpoint, Word 2010 MS Word, MS Visio, MS Communicator, OneNote 2010 MS OneNote, Publisher 2010 MS Publisher, InfoPath 2010 InfoPath, SharePoint Workspace 2010 SharePoint Workspace, Lync Lync


A&A® - Work smart, not hard.

Excel VBA - Copie qualquer objeto como imagem e exporte-o


Lembro-me de há alguns, quando criei este Blog específico de VBA, como ainda era incipiente a inter-colaboração de códigos VBA no mercado nacional, bem como a utilização profissional de Dashboards e Scorecards. O desenvolvimento VBA naquela época restringia-se aos expressão "faz-se macros no excel'. Hoje, estamos vivenciando um mercado de desenvolvimento VBA mais maduro, cheio de profissionais competentíssimos (tomara que essa expressão não seja um neologismo), com inúmeras excelentes soluções de desenvolvimento e aplicações de automação. Encontramo-nos amadurecidos e prontos para avançarmos no nosso ciclo de aprimoramento profissional!

English references:
You can export a chart to an image file using VBA
Chart to Image Conversion using VBA
Excel Chart to GIF Conversion using VBA
Export Excel Chart to Image using VB
Save Chart as image
Export function of the Chart
To copy a selected Excel chart or range object as a picture
Image File Type Comparison of Exported Charts
Image Export - Org Chart in Excel Worksheet
Best format to export Excel Range to picture
Export Chart as Image: Run-time error 1004
Exporting a Chart(object) EXCEL VBA
Saving a chart as a picture file
Paste Chart from Excel to VBA form
Using VBA to Export Charts as Images in Excel 2007
How can I export a chart as a jpg/tif? in Excel Charting?
How to superimpose chart images or extract data by vba in Excel?
How to convert Excel to jpg, gif image?
How to Export A Picture Or Chart From Excel To Powerpoint?


O artigo a seguir visa elevar a qualidade da nossa entrega. Enviar o conteúdo das nossas soluções para outros ambientes e interfaces. Das 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 automático (Sharepoint). Mas prá que quero isso? Talvez pergunte-se. Abaixo seguem 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) como uma imagem. 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, num documento MS Word, num e-mail 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! Tags: André Luiz Bernardes, TI, Tecnologia da Informação, Dashboard, Scorecard, Infographic, infochart, infográfico, portfolio, YTD, YTG, KPI, sparklines, charts, Pivot Table, slicers, bullet, Scroll chart, gráfico, mini-gráfico, termômetro, Velocímetro, Gauge, relatório, MS, Microsoft, Office, Excel, Access, Outlook, Powerpoint, Organização, Ordenação, Formatação, numérico, projeto, ranqueado, painel, clustering, redes neurais, métodos genéticos, mineração em textos, roll up, drill down, KPI, KPIs, Key performance Indicator, escopo, stakeholder, indicadores, DW, Data Warehousing, BSM, Business Scorecard Manager, BSC, Balanced Scorecard, Dashboard, características, infochart, chart, infográfico, gráfico, drugs, drogas, Ilegal, Américas, análise, Data Mining Tweeder, The Health Tweeder, algoritmo, data mining, Mineração de Dados, colaborativa, rede social, social mídia, community, facebook, like, friendwheel, google play, health tweeder, infographic, keyword, like button, likebutton.me, mentionmap, MSNBC spectra, network,news feed, rss, search, topics, touchgraph, twitter, twitter venn, visual, evolução, dólar, Real, superimposição, finanças, financeiro, contábil, contabilidade, crédito, débito

eBooks VBA na AMAZOM.com.br

LinkWithinBrazilVBAExcelSpecialist

Related Posts Plugin for WordPress, Blogger...

Vitrine