Hi I'm trying to work through a table downloaded from a 3rd party that uses ticks (shapes) rather than text in the cells. The shapes have no textframe characters. I can't filter the ticks in excel so I want to replace then with text e.g. Yes. Here is my working code but get run time error 438 due to object errors I have tried the excel vba object model but can't get it to work. The VBE doesn't seem to have the Selection.ShapeRange
https://learn.microsoft.com/en-us/office/vba/api/excel.shape
https://learn.microsoft.com/en-us/office/vba/api/excel.shaperange
Here is my code
Sub ReplaceShapeswithYes()
' Inserts text where a shape exists
Dim ws As Worksheet
Dim NumRow As Integer
Dim iRow As Integer
Dim NumShapes As Long
Set ws = ActiveSheet
NumRow = ws.UsedRange.Rows.Count
For iRow = 2 To NumRow
Cells(iRow, 10).Select
'NumShapes = ActiveWindow.Selection.ShapeRange.Count ' tried both
NumShapes = Windows(1).Selection.ShapeRange.Count
If NumShapes > 0 Then
Cells(iRow, 10).Value = "Yes"
End If
Next iRow
End Sub
Many thanks
To get all shapes of a sheet, simply loop over the Shapes-collection of the sheet.
The text of a shape can be read with TextFrame.Characters.Text, but to be on the save side, you will need to check if a shape has really text (there are shapes that don't have any), see https://stackoverflow.com/a/16174772/7599798
To get the position withing a sheet, use the TopLeftCell-property.
The following code will copy the text of all shapes into the sheet and delete the shapes:
Sub shapeToText(Optional ws As Worksheet = Nothing)
If ws Is Nothing Then Set ws = ActiveSheet
Dim sh As Shape
For Each sh In ws.UsedRange.Shapes
If Not sh.TextFrame Is Nothing Then
If sh.TextFrame2.HasText Then
Dim s As String
s = sh.TextFrame.Characters.Text
sh.TopLeftCell = s
sh.Delete
End If
End If
Next
End Sub
This has done the trick
Sub ReplaceShapes()
'Replace all ticks with text
Dim NoShapes As Long
Dim iShape As Long
Dim ws As Worksheet
Dim r As Range
Dim Shp As Shape
Set ws = ActiveSheet
NoShapes = ws.Shapes.Count
For iShape = NoShapes To 1 Step -1:
Set Shp = ws.Shapes(iShape)
Set r = Shp.TopLeftCell
r.Value = "Yes"
Next iShape
End Sub
Related
I have this error with my macro. My macro takes data from a table and in another sheet, outputs in a table my data for each value of a third sheet.
So let's say my table's value are : Jack and Daniel. And on my third sheet, I have Football and Rugby. The output in the second page will be :
Jack Football
Jack Rugby
Daniel Football
Daniel Rugby
Here is my macro :
Sub yo()
Dim Letters, Chk, Ele As Range, i As Long: Letters = Sheets("Sports").Range("C3:C5").Value
For Each Ele In Sheets("Students").ListObjects(1).ListColumns(1).DataBodyRange
With Sheets("OK").ListObjects(1)
Chk = Application.Match(Ele, .ListColumns(1).Range, 0)
If IsError(Chk) Then
For i = 1 To 3
.ListRows.Add.Range = Array(Ele, Letters(i, 1))
Next i
End If
End With
Next Ele
End Sub
However this works fine. The problem comes from all the other columns of the table in my second sheet. They all get the value "#NA". So instead of having nothing or formulas expanding down, there is that error.
How can I overcome this error ?
Copy to Excel Table (ListObject)
The short answer is that in this case a ListRow has four columns yet you're assigning it an array of only two. By the looks of your answer, you have concluded this yourself (.Resize(, 2)).
An Improvement
Option Explicit
Sub AddStudents()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsSports As Worksheet: Set wsSports = wb.Sheets("Sports")
Dim Sports(): Sports = wsSports.Range("C3:C5").Value
Dim SportsCount As Long: SportsCount = UBound(Sports, 1)
Dim wsStudents As Worksheet: Set wsStudents = wb.Sheets("Students")
Dim loStudents As ListObject: Set loStudents = wsStudents.ListObjects(1)
Dim lcStudents As ListColumn: Set lcStudents = loStudents.ListColumns(1)
Dim rgStudents As Range: Set rgStudents = lcStudents.DataBodyRange
Dim wsOK As Worksheet: Set wsOK = wb.Sheets("OK")
Dim loOK As ListObject: Set loOK = wsOK.ListObjects(1)
Dim lcOK As ListColumn: Set lcOK = loOK.ListColumns(1)
Dim rgOK As Range: Set rgOK = lcOK.DataBodyRange
Dim cell As Range, Student, MatchOK, r As Long, IsNotStudentAdded As Boolean
For Each cell In rgStudents.Cells
If rgOK Is Nothing Then
IsNotStudentAdded = True
Else
MatchOK = Application.Match(cell.Value, rgOK, 0)
If IsError(MatchOK) Then IsNotStudentAdded = True
End If
If IsNotStudentAdded Then
Student = cell.Value
For r = 1 To SportsCount
loOK.ListRows.Add.Range.Resize(, 2).Value _
= Array(Student, Sports(r, 1))
Next r
IsNotStudentAdded = False
Set rgOK = lcOK.DataBodyRange
End If
Next cell
MsgBox "Students added.", vbInformation
End Sub
So I decided to completely change my macro to avoid any error :
Sub Macro7()
Dim N, S, i, j
Application.ScreenUpdating = False
N = Range("Tableau1"): S = Sheets("Sports").Range("C3:C5").Value
With Range("Tableau2").ListObject
If .ListRows.Count > 0 Then .DataBodyRange.Delete
For Each i In N
For Each j In S
.ListRows.Add.Range.Resize(, 2) = Array(i, j)
Next
Next
End With
End Sub
I would like to create a presentation based on data sorted in rows:
That, in the PowerPoint, would appear as this
But I am having difficulties understanding the correct syntax to properly have this done inside PowerPoint, rather than the Excel where the data comes from: how to declare/deal with the range of cells that become each a slide and in each of them of how to fill the relative placeholder, or "transposed/cut" place in table. I have looked everywhere, the very few pages/articles I found are not clear and overall short of explanation. I am stuck at the very beginning of this as I don't know how to set up the variable range of cells or if it should be an array to split later in different ranges, I would know how to continue, once I understood how to link Excel to PowerPoint Layouts/Slides/Objects.
I know I have to set a counter for each step, i.e. on for the change in Section #, in in the Slide # etc., mostly I find not clear how to translate the different parts of the table in rows and then section of rows.
EDIT: With code I have come up so far, this was the most helpful resource I could find. However I have the problem I was mentioning before: I do I swap the row I have left to columns in the table? How do I change them in a Range?
I referenced Excel for PowerPoint as from the original code, but the selection does no get recognized in POwerPoint (as said above, I would like to use it in PPT, not in Excel) . However, it works only in Excel, I have an error at For Each DataRow In DataRange.Rows variable not set when running as pptm. (reciprocal Libraries enabled in both programs).
From Excel, I can populate the title and the heading (so "AAA" and "aa") but I do not know how to progress in the cells, transposing the values for some columns and then restart.
Update:
I added a variable for the the columns of the source, but I am not sure how to deal with it. I'm so close but I don't know how to finish it. I introduced the variable FirstRowToColumn as range (columns E to the Excel screenshot below, that would become the first column of the tabel in PowerPoint), but I don't know how to declare this and the others range and paste them into the table. Could someone please teach me this or point to the solution, am I at least close ?
Edit2: added, with which I would copy the range and paste transposed, but it says the area is different.
Edit3: I can paste, I have to fix the counter to have the table in each slide, but the question of how to transpose remains and on top of that how to write the values in the Powerpoint table.
Edit 4:
I am trying a new way, by pasting in the Object placeholder id, but I saee nothing appearing in the table.
Sub General_Namer_For_Slides_And_Shapes()
Dim AnySlide As Slide
Dim AnyShape As Shape
Set AnySlide = Application.ActivePresentation.Slides(1)
For Each AnyShape In AnySlide.Shapes
Debug.Print "Application.ActivePresentation.Slides(1) AnySlide.Shapes AnyShape.Name " & AnyShape.Name & " AnyShape.Id "; AnyShape.Id '''names of each shape and their id '''removed " Slide " & AnySlide.SlideID&;
Next
Debug.Print "ActivePresentation.Slides(1).CustomLayout.Name " & ActivePresentation.Slides(1).CustomLayout.Name & " ActivePresentation.Slides(1).CustomLayout.Index " & ActivePresentation.Slides(1).CustomLayout.Index&;
Debug.Print " There are " & ActivePresentation.SlideMaster.Design.SlideMaster.CustomLayouts(4).Shapes.Count & " shapes in the Layout slide (SlideMaster View)"
'Debug.Print "ActivePresentation.Designs(4).Name = " & ActivePresentation.Designs(1).SlideMaster.CustomLayouts(4); ""
'Debug.Print " ActivePresentation.Designs.Name" & ActivePresentation.SlideMaster.Shapes.Placeholders. & ; ActivePresentation.Designs(4).Index; " & ActivePresentation.Designs(4).Index "
End Sub
Set NewTable = sld.Shapes.AddTable(12, 4)
FirstRowToColumn.Cells.PasteSpecial Paste:=-4163, Transpose:=True
to
Sub LoopRowsSelectedXCLToPPT()
Dim xlApp As Object
Dim xlWorkBook As Object
Dim xlSheet As Object
Dim DataRange As Range 'used
Dim DataRow As Range 'used
Dim DataCol As Range 'used
Dim PPTrng As Range ''cloning here the above to use in PowerPoint
Dim ShpRng As ShapeRange ''cloning here the data raw as range of shapes i could create later
Dim ShpCll As Shape
Dim AppPPT As PowerPoint.Application
Dim Pres As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim AppXCL As Excel.Application 'repeated the same as above with Excel as argument
Dim InputSheet As Excel.Worksheet
Set AppPPT = GetObject(, "PowerPoint.Application")
Set Pres = AppPPT.ActivePresentation
Set AppXCL = GetObject(, "Excel.Application")
Set InputSheet = AppXCL.ActiveSheet
Dim RowCounter As Integer
Dim ColCounter As Integer
Dim iRow As Integer
Dim iColumn As Integer
Dim FirstRowToColumn As Range
Dim SecondRowToColumn As Range
RowCounter = 0
ColCounter = 0
Set DataRange = Selection
For Each DataRow In DataRange.Rows
RowCounter = RowCounter + 1
Set sld = Pres.Slides.AddSlide(Pres.Slides.Count + 1, Pres.SlideMaster.CustomLayouts(4))
sld.Shapes.Title.TextFrame.TextRange.Text = DataRow.Cells(3, 3)
sld.Shapes.Placeholders(4).TextFrame.TextRange.Text = DataRow.Cells(3, 4)
' For Each DataCol In DataRange.Columns
ColCounter = ColCounter + 1
Set FirstRowToColumn = DataRange.Range(Cells(RowCounter + 1, 5), Cells(RowCounter + 1, 10))
FirstRowToColumn.Copy
Set NewTable = sld.Shapes.AddTable(12, 4)
sld.Shapes.Placeholders(4).TextFrame.TextRange.Text = FirstRowToColumn.Cells(1, 5)
' FirstRowToColumn.Cells(1, 10) =
' With sld.Shapes.Placeholders
' NewTable.Range(1,1)
'
'
' End With
' With sld.Shapes.Paste.SpecialPaste:=-4163, Transpose:=True
Next DataRow
Debug.Print RowCounter
Debug.Print ColCounter
End Sub
You may have to finesse the details but this works for me:
Sub LoopRowsSelectedXCLToPPT()
Const TABLE_COLS As Long = 5 '# of columns in PPT tables
Const BLOCK_SIZE As Long = 5
Dim Datarange As Range, rw As Range, rng As Range, i As Long, col As Long
Dim ppApp As PowerPoint.Application, pres As PowerPoint.Presentation
Dim sld As PowerPoint.Slide, newTable As PowerPoint.Table
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
Set pres = ppApp.ActivePresentation
On Error GoTo 0
If pres Is Nothing Then
MsgBox "Destination presentation must be open in PowerPoint", vbCritical
Exit Sub
End If
Set Datarange = Selection
For Each rw In Datarange.Rows
Set sld = pres.Slides.AddSlide(pres.Slides.Count + 1, _
pres.SlideMaster.CustomLayouts(2))
Set newTable = sld.Shapes.AddTable(BLOCK_SIZE, TABLE_COLS).Table
col = 0
Set rng = rw.Cells(5).Resize(1, BLOCK_SIZE) 'first BLOCK_SIZE cells starting from Col E
Do While Application.CountA(rng) > 0 'while have any data in `rng`
col = col + 1
If col > TABLE_COLS Then Exit Do 'ran out of columns in the PPT table...
For i = 1 To BLOCK_SIZE 'fill column # col
newTable.Cell(i, col).Shape.TextFrame2.TextRange.Text = rng.Cells(i).Value
Next i
Set rng = rng.Offset(0, BLOCK_SIZE) 'next block of cells to the right
Loop
Next rw
End Sub
I keep getting
runtime error 1004 - Application defined or object defined error
for the code below. Could you help me figure out why this is happening?
Option Explicit
Sub DeleteSheet()
Dim Sh As Worksheet
Application.DisplayAlerts = False
For Each Sh In ThisWorkbook.Worksheets
If Application.WorksheetFunction.Search("Generation", Sh.Range("A1").Value, 1) = 1 Then
Sh.Delete
End If
Next Sh
Application.DisplayAlerts = True
End Sub
You can't delete a sheet which is also a control variable in a loop. Use a counter instead to iterate through the sheets, then delete using the counter, eg
dim sheetCount
dim i
sheetCount = ThisWorkbook.Worksheets.Count
for i = sheetCount to 1 step -1
dim sh as Worksheet
set sh = ThisWorkbook.Worksheets(i)
If Application.WorksheetFunction.Search("Generation", sh.Range("A1").Value, 1) = 1 Then
ThisWorkbook.Worksheets(i).Delete
End If
next i
Delete Worksheets Using an Array of Worksheet Names
I couldn't reproduce the exact error.
The covered scenarios producing errors were the following:
when generation was not found in cell A1,
the last sheet cannot be deleted,
when a sheet was very hidden.
VBA has its own FIND or SEARCH equivalent called Instr.
In the workbook containing this code (ThisWorkbook), it will delete all worksheets whose cell A1 contains a string starting with Generation.
Option Explicit
Sub DeleteSheets()
Dim wsCount As Long: wsCount = ThisWorkbook.Worksheets.Count
Dim wsNames() As String: ReDim wsNames(1 To wsCount) ' Worksheet Names Array
Dim ws As Worksheet
Dim n As Long
For Each ws In ThisWorkbook.Worksheets
' Check if 'A1' contains a string starting with 'Generation'.
If InStr(1, CStr(ws.Range("A1").Value), "Generation", _
vbTextCompare) = 1 Then
n = n + 1 ' next array element
wsNames(n) = ws.Name ' write the worksheet name to the array
End If
Next ws
' Check if no worksheet name was added to the array.
If n = 0 Then Exit Sub
' Resize the array to the number of found worksheets.
If n < wsCount Then ReDim Preserve wsNames(1 To n)
' Delete the worksheets, without confirmation, in one go.
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(wsNames).Delete
Application.DisplayAlerts = True
End Sub
An over-simplified description of my problem is illustrated in the figures below. I want to transform sparse data from a column in the Page1 worksheet to dense and then load it in a dense range in the Page2 worksheet.
My solution so far is that in the following code snippet. I would like to know if there is a more efficient alternative to achieve this goal, namely without a for loop or at least without the j variable.
Sub CopyFromMultipleRanges()
With Worksheets("Page1")
.Range("A1:A5").Value = 1
.Range("A8:A10").Value = 2
Dim c_cell As Range
Dim j As Long
j = 1
For Each c_cell In .Range("A1:A5,A8:A10")
Worksheets("Page2").Range("A" & j).Value = c_cell.Value
j = j + 1
Next
End With
Worksheets("Page2").Activate
End Sub
Initial column where data is sparse.
Final dense data column.
You can do this if you want to remove the blanks on the same sheet. If not just copy the data to a new sheet and then run this on that range
Sub Delete_Blank_Rows()
On Error Resume Next
Range("A1:A10").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Here's how I would do it:
'create a collection to store the data
Dim bin As New Collection
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim size As Long
Dim i As Long
Dim v As Variant
'set worksheet references
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Page1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Page2")
With ws1
size = .UsedRange.Rows.Count
'loop through the range to pick up the data from non-empty cells
For i = 1 To size
'if the cell is not empty, then add the value to the collection
If Not IsEmpty(.Cells(i, 1).Value) Then
bin.Add .Cells(i, 1).Value
End If
Next
'loop through the bin contents
i = 1
For Each v In bin
ws2.Cells(i, 1).Value = v
i = i + 1
Next
End With
Hope it helps!
Update:
I tested this code and it works:
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Excel.Application.ThisWorkbook.Worksheets(1)
Set ws2 = Excel.Application.ThisWorkbook.Worksheets(2)
ws1.Range("A:A").SpecialCells(xlCellTypeConstants).Copy ws2.Range("A:A")
End Sub
you can read more about Range.SpecialCells here. learn something new everyday!
This assumes that you are considering the all rows with the lower and upper row limits of the ranges given ie. that "A1:A5" and "A8:A10" is indeed "A1:A10".
Option Explicit
Public Sub CopyFromMultipleRanges()
Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Page1").Range("A1:A10")
Application.ScreenUpdating = False
If Application.WorksheetFunction.CountBlank(rng) = rng.Count Then Exit Sub
With rng
.AutoFilter
.AutoFilter 1, "<>"
.SpecialCells(xlCellTypeVisible).Copy Worksheets("Page2").Range("A1")
.AutoFilter
Application.ScreenUpdating = True
End With
End Sub
I have written the following code to create worksheet with names same as the names in first column of Sheet1
I am getting a TypeError when trying to set the name on the new worksheet but don't know why. Can someone help?
Sub CreateWorkSheets()
'
' Macro5 Macro
'
'
Dim r As Range
Set r = Sheets("Sheet1").Columns(1)
For Each cell In r
Dim aa As String
Dim newSheet As Worksheet
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
strTemp = cell.Value
newSheet.Name = strTemp // Error Here
Next cell
End Sub
I tried the following code as well and that doesn't work either even though strValue is valid
Sub Test1()
Sheets("Sheet1").Select
Dim x As Integer
' Set numrows = number of rows of data.
NumRows = Range("A2", Range("A2").End(xlDown)).rows.Count
' Select cell a1.
Range("A2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
Dim newSheet As Worksheet
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
Sheets("Sheet1").Range("B1").Value = "A" + Trim(Str(x))
strValue = "A" + Trim(Str(x))
newSheet.Name = Str(Sheets("Sheet1").Range(strValue).Value)
Next
End Sub
Apparently because you set:
Set r = Sheets("Sheet1").Columns(1)
It set the cell object to column $A:$A instead of $A$1 like you would think. I put this in the immediate window when I ran into the "cell.value" line:
?cell.Address
$A:$A
You should avoid using an entire column to do what you're trying to do and I would highly recommend you add these keywords to the top of your module:
Option Explicit
This will check your code a little more thoroughly and help you avoid unwanted errors.
To fix this, you can get the exact range you need and I recommend you declare every variable so it stays a specific type.
Something like this:
Option Explicit
Sub CreateWorkSheets()
Dim r As Range
Dim sh As Worksheet
Dim tempSh As Worksheet
Dim cell As Range
Dim strTemp As String
Set sh = Sheets("Sheet1")
Set r = sh.Range(sh.Cells(1, 1), sh.Cells(sh.Rows.Count, 1).End(xlUp))
For Each cell In r
Set tempSh = Sheets.Add(After:=Sheets(Sheets.Count))
strTemp = cell.Value
tempSh.Name = strTemp '// no more error
Next cell
End Sub