I am using the following VBA Macro to delete all the pictures in a PowerPoint slide:
Public Function delete_slide_object(slide_no)
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
' Delete object in slide
Set PPSlide = PPPres.Slides(slide_no)
For Each PPShape In PPSlide.Shapes
If PPShape.Type = msoPicture Then
PPShape.Delete
End If
Next PPShape
Set PPShape = Nothing
Set PPSlide = Nothing
Set PPPres = Nothing
End Function
This code is deleting some but not all the pictures.After running this code 3 times , all the pictures get deleted. Where am i going wrong? Kindly let me know
When deleting items from a collection, you have to use a different iteration.
Try this:
Dim p as Long
For p = PPSlide.Shapes.Count to 1 Step -1
Set PPShape = PPSlide.Shapes(p)
If PPShape.Type = msoPicture Then PPShape.Delete
Next
This is because the collection is re-indexed when items are removed, so if you delete Shapes(2) then what was previously Shapes(3) becomes Shapes(2) after the deletion, and is effectively "skipped" by the loop. To avoid this, you have to start with the last shape, and delete them in reverse order.
Related
I'm writing a script that will extract the contents of a column in an Excel spreadsheet. Since I don't know how many rows will have data, I need to be able to find the end of the column in the course of the script.
In VBA, I would use something like
sht.Range(sht.Cells(row, col), sht.Cells(row, col)).End(xlDown).row
When I tried using that line in the VBScript file (I knew it probably wouldn't work, but I was hoping for some good luck), a message came back saying that 'xlDown' is undefined. I could easily create an Excel macro to do this, but I want the program to run without having to alter the original spreadsheet.
Here's part of my current script where I define the Excel objects
Set fso = CreateObject("Scripting.FileSystemObject")
set xlapp = CreateObject("Excel.Application")
Set wkbk = xlapp.Workbooks.Open(path)
'xlapp.Visible = False
Set sht = wkbk.Sheets(sheetname)
Set myfile = fso.OpenTextFile(txtfile, 2, True)
lrow = sht.Range(sht.Cells(row, col), sht.Cells(row, col)).End(xlDown).row
path, sheetname, and txtfile are previously defined strings, and row and col are previously defined integers.
xlDown is actually a constant. It's value is -4121 as mentioned HERE.
So try something like,
const xlDown = -4121
lrow = sht.Range(sht.Cells(row, col), sht.Cells(row, col)).End(xlDown).row
OR you can make use of xlUp also in the following code to get the rowcount of a column say Column A:
const xlUp = -4162
lrow = sht.Range("A" & sht.Rows.Count).End(xlUp).Row
Glad that it worked. Here is simple one which will give you the count of rows in the used range for sheet sht
lrow = sht.UsedRange.Rows.Count
So I've seen a couple posts on this topic, but can't seem to find a way to get it to work. My goal is to create a Stacked Column Graph using VBA with the following characteristics:
Each column is based on data from a row (e.g. E6:P6, E7:P7, etc.).
Each "stack section" is each column in that row (located at E4:P4)
X Axes Labels are located in column A (e.g. A6, A7, etc.)
Y Axes Labels dynamic based on data (non specific).
Chart Title (which is the easy part - I got this).
Granted I also need the legend which shows the color key used by item 2.
This graph is one of three needed per report across 30+ reports that I generated via VBA from a raw data file. The last step to the reports is to make these graphs.
I am able to get stacked graph created, but the biggest problem is that as the data ranges above show, there are gaps in the data. This causes split sections in the graph as well as additional labels that I don't want. Essentially I don't know how to format the graph, and reading the Object Window that pops up from typing "ActiveChart." has only gotten me this far. If I know various formatting commands (alas I'm new to VBA with Excel), I can replicate it across all the charts that I need.
Dim data As Range
Set data = Range("A4:P12")
With Charts.Add
.ChartType = xlColumnStacked
.SetSourceData Source:=data, PlotBy:=xlColumns
.HasTitle = True
.ChartTitle.Text = "Weekly Report"
.Location Where:=xlLocationAsObject, Name:="Sheet1"
End With
Example of what I can make:
Output Graph
Side note about the blank data: The leftmost blank spot where a bar would be is the empty column D. Also I need to be able to edit the axes labels.
How about something like this:
Public Sub MakeGraph()
Dim ws As Excel.Worksheet
Dim data As Excel.Range
Dim x_axis_labels As Excel.Range
Dim series_names As Excel.Range
Dim sh As Excel.Shape
Dim ch As Excel.Chart
Dim I As Long
Set ws = Sheet1
Set data = ws.Range("E4:P12") ' Assumes the data are in E4:P12
Set x_axis_labels = ws.Range("A4:A12") ' Assumes the labels are in A4:A12
Set series_names = ws.Range("E2:P2") ' Assumes the labels are in E2:P2
Set sh = ws.Shapes.AddChart
Set ch = sh.Chart
With ch
.ChartType = xlColumnStacked
.SetSourceData Source:=data, PlotBy:=xlColumns
.HasTitle = True
.ChartTitle.Text = "Weekly Report"
.Axes(xlCategory, xlPrimary).CategoryNames = x_axis_labels
' Add series names
For I = 1 To .SeriesCollection.Count
.SeriesCollection(I).Name = series_names.Cells(1, I)
Next I
End With
Set ch = Nothing
Set sh = Nothing
Set series_names = Nothing
Set x_axis_labels = Nothing
Set data = Nothing
Set ws = Nothing
End Sub
Hope that helps
I take it your missing data would be a column in the range E6:P14? (I'm using E6:P14 because that's what you said first. Your code and #xidgel's later said E4:P12.)
Try this:
Sub MakeChart()
Dim rCats As Range
Dim rNames As Range
Dim rData As Range
Dim iCol As Long
Set rCats = ActiveSheet.Range("A6:A14")
Set rNames = ActiveSheet.Range("E4:P4")
Set rData = ActiveSheet.Range("E6:P14")
With ActiveSheet.Shapes.AddChart(xlColumnStacked).Chart
Do Until .SeriesCollection.Count = 0
.SeriesCollection(1).Delete
Loop
For iCol = 1 To rData.Columns.Count
If WorksheetFunction.Count(rData.Columns(iCol)) > 0 Then
' it's not blank
With .SeriesCollection.NewSeries
.Values = rData.Columns(iCol)
.XValues = rCats
.Name = "=" & rNames.Cells(1, iCol).Address(, , , True)
End With
End If
Next
End With
End Sub
I am using the following code to remove hidden/filtered lines after applying autofilters to a big sheet in VBA (big means roughly 30,000 rows):
Sub RemoveHiddenRows()
Dim oRow As Range, rng As Range
Dim myRows As Range
With Sheets("Sheet3")
Set myRows = Intersect(.Range("A:A").EntireRow, .UsedRange)
If myRows Is Nothing Then Exit Sub
End With
For Each oRow In myRows.Columns(1).Cells
If oRow.EntireRow.Hidden Then
If rng Is Nothing Then
Set rng = oRow
Else
Set rng = Union(rng, oRow)
End If
End If
Next
If Not rng Is Nothing Then rng.EntireRow.Delete
End Sub
The code comes from here: Delete Hidden/Invisible Rows after Autofilter Excel VBA
Moreover I read this thread: Speeding Up Code that Removes Hidden Rows on a Sheet
The situation: I have applied 5 different filters to a table consisting of 12 columns, therefore a lot of rows are filtered out (hidden) after the process. When I try to delete those, the code above takes a very long time. In my case I don't know if Excel was still working, so I had to force an exit. That leads to the following question:
Is there any other way than looping through all the hidden rows and deleting them?
An idea which came to my mind was to copy only the remaining unfiltered (that is non-hidden) content to a new sheet and afterwards delete the old sheet, which contains the full information. If so, how can that be done?
I don't think you need to involve another worksheet. Simply copy the rows below the existing Range.CurrentRegion property and then remove the filter and delete the original data.
Sub RemoveHiddenRows()
With Sheets("Sheet10")
With .Cells(1, 1).CurrentRegion
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If CBool(Application.Subtotal(103, .Columns(1))) Then
.Cells.Copy Destination:=.Cells(.Rows.Count + 1, 1)
End If
.AutoFilter
.Cells(1, 1).Resize(.Rows.Count, 1).EntireRow.Delete
End With
End With
End With
End Sub
You may also receive some good, focused help on this subject by posting on Code Review (Excel).
You can improve performance significantly with a function like this:
Option Explicit
Public Sub deleteHiddenRows(ByRef ws As Worksheet)
Dim rngData As Range, rngVisible As Range, rngHidden As Range
With ws
Set rngData = .UsedRange
With rngData
Set rngVisible = .SpecialCells(xlCellTypeVisible)
Set rngHidden = .Columns(1)
End With
End With
If Not (rngVisible Is Nothing) Then
ws.AutoFilterMode = False
' invert hidden / visible
rngHidden.Rows.Hidden = False
rngVisible.Rows.Hidden = True
' delete hidden and show visible
rngData.SpecialCells(xlCellTypeVisible).Delete
rngVisible.Rows.Hidden = False
End If
End Sub
I tested it on a file with 2 filters applied to it
The function was adapted from the code in this suggestion
I got a weird mission from a friend, to parse through a bunch of Word files and write certain parts of them to a text file for further processing.
VBscript is not my cup of tea so I'm not sure how to fit the pieces together.
The documents look like this:
Header
A lot of not interesting text
Table
Header
More boring text
Table
I want to parse the documents and get all the headers and table of contents out of it. I'm stepping step through the document with
For Each wPara In wd.ActiveDocument.Paragraphs
And I think I know how to get the headers
If Left(wPara.Range.Style, Len("Heading")) = "Heading" Then
But I'm unsure of how to do the
Else if .. this paragraph belongs to a table..
So, any hint on how I could determine if a paragraph is part of a table or not would be nice.
Untested, because I have no access to MS Word right now.
Option Explicit
Dim FSO, Word, textfile, doc, para
' start Word instance, open doc ...
' start FileSystemObject instance, open textfile for output...
For Each para In doc.Paragraphs
If IsHeading(para) Or IsInTable(para) Then
SaveToFile(textfile, para)
End If
Next
Function IsHeading(para)
IsHeading = para.OutlineLevel < 10
End Function
Function IsInTable(para)
Dim p, dummy
IsInTable = False
Set p = para.Parent
' at some point p and p.Parent will both be the Word Application object
Do While p Is Not p.Parent
' dirty check: if p is a table, calling a table object method will work
On Error Resume Next
Set dummy = obj.Cell(1, 1)
If Err.Number = 0 Then
IsInTable = True
Exit Do
Else
Err.Clear
End If
On Error GoTo 0
Set p = p.Parent
Loop
End Function
Obviously SaveToFile is something you'd implement yourself.
Since "is in table" is naturally defined as "the object's parent is a table", this is a perfect situation to use recursion (deconstructed a little further):
Function IsInTable(para)
IsInTable = IsTable(para.Parent)
If Not (IsInTable Or para Is para.Parent) Then
IsInTable = IsInTable(para.Parent)
End If
End Function
Function IsTable(obj)
Dim dummy
On Error Resume Next
Set dummy = obj.Cell(1, 1)
IsTable = (Err.Number = 0)
Err.Clear
On Error GoTo 0
End Function
Sub Prats
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objRawData = objExcel.Workbooks.Open("C:\A.xlsx") 'Copy From File
Set objPasteData= objExcel.Workbooks.Open("C:\B.xlsx") 'Paste To File
Set obj1 = objPasteData.WorkSheets("Sheet1") 'Worksheet to be cleared
obj1.Cells.Clear
countSheet = objRawData.Sheets.Count
log.Message("Prats " &countsheet)
For i = 1 to countSheet
objRawData.Activate
name = objRawData.Sheets(i).Name
objRawData.WorkSheets(name).Select
objRawData.Worksheets(name).Range("A1").Select
objExcel.ActiveSheet.UsedRange.Select
usedRowCount2 = objExcel.Selection.Rows.Count
objExcel.Range("A1:B" & usedRowCount2).Copy
objPasteData.Activate
objPasteData.WorkSheets("Sheet1").Select
objExcel.ActiveSheet.UsedRange.Select
usedRowCount1= objExcel.Selection.Rows.Count
objExcel.ActiveSheet.UsedRange.Select
objExcel.Range("A" & usedRowCount1).Select
objPasteData.Worksheets("Sheet1").Range("A" &(usedRowCount1+1)).PasteSpecial Paste =xlValues
Next
objPasteData.Save
End sub
This is the code that I am using.
The problem is it over rides the last row of the first sheet with the first row from the second sheet.
I already told the person you copied the code from that he should use the Cells property instead of working with ranges. However, if you absolutely must use ranges, at least refrain from activating and selecting all the time. The following lines should suffice for copying:
For i = 1 To countSheet
usedRowCount2 = objRawData.Sheets(i).UsedRange.Rows.Count
If i = 1 Then
usedRowCount1 = 0
Else
usedRowCount1 = objPasteData.Sheets(1).UsedRange.Rows.Count
End If
objRawData.Sheets(i).Range("A1:B" & usedRowCount2).Copy
objPasteData.Sheets(1).Range("A" & (usedRowCount1+1)).PasteSpecial -4163
Next
Edit: The UsedRange row count is at least 1, so usedRowCount1+1 produces an empty first row when copying the data from the first sheet. This row remains unused (i.e. it's not included in UsedRange), so the used row count is one less than the number of the last used row. Because of this you have to distinguish between the first sheet and all other sheets.