I am writing my first ms word macro which iterates through all rows of the table and deletes the selected one. Here is the code
Sub TableCleaner()
'
' TableCleaner Macro
'
'
Dim objTable As Table
Dim sourceDocument As Document
Set sourceDocument = ActiveDocument
Dim UserChoice As String
Dim QuestionToMessageBox As String
QuestionToMessageBox = "Delete row with Text?"
Dim targetRows() As Row
ReDim targetRows(1 To 1) As Row
For Each oRow In sourceDocument.Tables(1).Rows
UserChoice = MsgBox(oRow.Cells(1).Range.Text, vbYesNo, "Delete Row?")
If UserChoice = vbYes Then
targetRows(UBound(targetRows)) = oRow
ReDim Preserve targetRows(1 To UBound(targetRows) + 1) As Row
oRow.Shading.BackgroundPatternColor = Word.WdColor.wdColorLightGreen
End If
Next oRow
Confirmation = MsgBox("Are you sure?", vbYesNo, "Confirm?")
If Confirmation = vbYes Then
For Each targetRow In targetRows
targetRow.Delete
Next targetRow
End If
End Sub
I am following getting an error at line targetRows(UBound(targetRows)) = oRow
Compile error:
Invalid use of property
It's because a Row is an object, not a string, number or something "simple".
When you assign an object you need to use the keyword Set. (Happens to me all the time in similar situations!) So:
Set targetRows(UBound(targetRows)) = oRow
Note: You should use Option Explicit at the top of your code modules. That forces you to declare (use Dim) every variable you use and will help avoid spelling errors with variable names, etc.
You need to Set the target row:
Set targetRows(UBound(targetRows)) = oRow
In your code, on below line, it is expecting an index value like 1, 2, 3 for targetRows
targetRows(UBound(targetRows)) = oRow
Related
I am trying to read every two lines of text, create a slide, and insert each line in the cells of a 2 by 1 table respectively using VBA code.
Public Sub newSlide()
Dim FileNum As Integer
Dim DataLine As String
Dim Count As Integer
Count = 0
FileNum = FreeFile()
Open "C:\Users\ADMININST\Documents\my.txt" For Input As #FileNum
While Not EOF(FileNum)
Count = Count + 1
Line Input #FileNum, DataLine ' read in data 1 line at a time
' decide what to do with dataline,
' depending on what processing you need to do for each case
Debug.Print ("Love you")
If Count Mod 2 = 1 Then
Dim pptSlide As Slide
Dim pptLayout As CustomLayout
Set pptLayout = ActivePresentation.Slides(1).CustomLayout
Set pptSlide = ActivePresentation.Slides.AddSlide(2, pptLayout)
'ActivePresentation.Slides.Add Index:=ActivePresentation.Slides.Count + 1, Layout:=ppLayoutCustom
Dim pptTable As Table
pptTable = pptSlide.Shapes.AddTable(2, 1).Select
pptTable.Cell(1, Count Mod 2) = DataLine
End If
Wend
End Sub
I get a compile error;
"expected Function or variable" for the line below. It seems Select is not returning the table.
pptTable = pptSlide.Shapes.AddTable(2, 1).Select
Here's a rework of your code:
Dim pptTable As Shape
Set pptTable = pptSlide.Shapes.AddTable(2, 1)
pptTable.Table.Cell(1, Count Mod 2).Shape.TextFrame.TextRange.Text = DataLine
The object produced by Shapes.AddTable is a Shape, which contains a table. So I changed the Dim statement to make that work.
The Select is unneccessary. Using Set makes pptTable a shape that you can refer to.
When your code gets past that error, it runs into another in the next line. You need to refer to the Text inside the TextRange, inside the TextFrame, inside the Shape, inside the cell to place the string.
Option Explicit
Public Sub consolidateList()
DeleteTableRows (ThisWorkbook.Worksheets("Master").ListObjects("MasterSheet"))
FillTableRows
End Sub
Private Sub FillTableRows()
'set up worksheet objects
Dim wkSheet As Worksheet
Dim wkBook As Workbook
Dim wkBookPath As String
Set wkBook = ThisWorkbook
wkBookPath = wkBook.Path
Set wkSheet = wkBook.Worksheets("Master")
'set up file system objects
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(wkBookPath)
Set oFiles = oFolder.Files
'set up loop
Dim checkBook As Excel.Workbook
Dim reportDict As Dictionary
Application.ScreenUpdating = False
'initial coordinates
Dim startRow As Long
Dim startColumn As Long
startColumn = 3
Dim i As Long 'tracks within the row of the sheet where information is being pulled from
Dim k As Long 'tracks the row where data is output on
Dim j As Long 'tracks within the row of the sheet where the data is output on
Dim Key As Variant
j = 1
k = wkSheet.Range("a65536").End(xlUp).Row + 1
Dim l As Long
'look t Set checkBook = Workbooks.Open(oFile.Path)hrough folder and then save it to temp memory
On Error GoTo debuger
For Each oFile In oFiles
startRow = 8
'is it not the master sheet? check for duplicate entries
'oFile.name is the name of the file being scanned
'is it an excel file?
If Mid(oFile.Name, Len(oFile.Name) - 3, 4) = ".xls" Or Mid(oFile.Name, Len(oFile.Name) - 3, 4) = ".xlsx" Then
Set checkBook = Workbooks.Open(oFile.Path)
For l = startRow To 600
If Not (IsEmpty(Cells(startRow, startColumn))) Then
'if it is, time do some calculations
Set reportDict = New Dictionary
'add items of the payment
For i = 0 To 33
If Not IsEmpty(Cells(startRow, startColumn + i)) Then
reportDict.Add Cells(4, startColumn + i), Cells(startRow, startColumn + i)
End If
Next i
For i = startRow To 0 Step -1
If Not IsEmpty(Cells(i, startColumn - 1)) Then
reportDict.Add "Consumer Name", Cells(i, startColumn - 1)
Exit For
End If
Next i
'key is added
For Each Key In reportDict
'wkSheet.Cells(k, j) = reportDict.Item(Key)
Dim myInsert As Variant
Set myInsert = reportDict.Item(Key)
MsgBox (myInsert)
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
j = j + 1
Next Key
wkSheet.Cells(k, j) = wkSheet.Cells(k, 9) / 4
wkSheet.Cells(k, j + 1) = oFile.Name
'
k = k + 1
' Set reportDict = Nothing
j = 1
Else
l = l + 1
End If
startRow = startRow + 1
Next l
checkBook.Close
End If
' Exit For
Next oFile
Exit Sub
debuger:
MsgBox ("Error on: " & Err.Source & " in file " & oFile.Name & ", error is " & Err.Description)
End Sub
Sub DeleteTableRows(ByRef Table As ListObject)
On Error Resume Next
'~~> Clear Header Row `IF` it exists
Table.DataBodyRange.ClearContents
'~~> Delete all the other rows `IF `they exist
Table.DataBodyRange.Offset(1, 0).Resize(Table.DataBodyRange.Rows.count - 1, _
Table.DataBodyRange.Columns.count).Rows.Delete
On Error GoTo 0
End Sub
Greetings. The above code consolidates a folder of data that's held on excel spreadsheets into one master excel spreadsheet. The goal is to run a macro on Excel Spreadsheet named master on the worksheet named master which opens up other excel workbooks in the folder, takes the information, and puts it into a table in the worksheet "master". After which point, it becomes easy to see the information; so instead of it being held on hundreds of worksheets, the records are held on one worksheet.
The code uses a dictionary (reportDict) to temporarily store the information that is needed from the individual workbooks. The goal then is to take that information and place it in the master table at the bottom row, and then obviously add a new row either after a successful placement or before an attempted placement of data.
The code fails at the following line:
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
The failure description is "object or with variable not set" and so the issue is with the reportDict.Item(Key). My guess is that somehow VBA is not recognizing the dictionary item as stable, but I don't know how to correct this. Eventually the goal is to have code which does:
for each key in reportDict
- place the item which is mapped to the key at a unique row,column in the master table
- expand the table to accomodate necessary data
next key
Implicit default member calls are plaguing your code all over.
reportDict.Add Cells(4, startColumn + i), Cells(startRow, startColumn + i)
That's implicitly accessing Range.[_Default] off whatever worksheet is currently the ActiveSheet (did you mean that to be wkSheet.Cells?), to get the Key - since the Key parameter is a String, Range.[_Default] is implicitly coerced into one, and you have a string key. The actual dictionary item at that key though, isn't as lucky.
Here's a MCVE:
Public Sub Test()
Dim d As Dictionary
Set d = New Dictionary
d.Add "A1", Cells(1, 1)
Debug.Print IsObject(d("A1"))
End Sub
This procedure prints True to the debug pane (Ctrl+G): what you're storing in your dictionary isn't a bunch of string values, but a bunch of Range object references.
So when you do this:
Dim myInsert As Variant
Set myInsert = reportDict.Item(Key)
You might as well have declared myInsert As Range, for it is one.
This is where things get interesting:
MsgBox (myInsert)
Nevermind the superfluous parentheses that force-evaluate the object's default member and pass it ByVal to the MsgBox function - here you're implicitly converting Range.[_Default] into a String. That probably works.
So why is this failing then?
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
Normally, it wouldn't. VBA would happily do this:
wkSheet.ListObjects(1).DataBodyRange.Cells(2, 1).[_Default] = reportDict.Item(Key).[_Default]
And write the value in the DataBodyRange of the ListObject at the specified location.
I think that's all just red herring. Write explicit code: if you mean to store the Value of a cell, store the Value of a cell. If you mean to assign the Value of a cell, assign the Value of a cell.
I can't replicate error 91 with this setup.
This, however:
DeleteTableRows (ThisWorkbook.Worksheets("Master").ListObjects("MasterSheet"))
...is also force-evaluating a ListObject's default member - so DeleteTableRows isn't receiving a ListObject, it's getting a String that contains the name of the object you've just dereferenced... but DeleteTableRows takes a ListObject parameter, so there's no way that code can even get to run FillTableRows - it has to blow up with a type mismatch before DeleteTableRows even gets to enter. In fact, it's a compile-time error.
So this is a rather long answer that doesn't get to the reason for error 91 on that specific line (I can't reproduce it), but highlights a metric ton of serious problems with your code that very likely are related to this error you're getting. Hope it helps.
You need to iterate through the dictionary's Keys collection.
dim k as variant, myInsert As Variant
for each k in reportDict.keys
debug.print reportDict.Item(k)
next k
I have an issue with my VBA script which I'm not able to resolve, despite of all the researches I've made (Indeed, I tried to modify all the vba scripts which were near what I'm looking for, but it doesn't work).
Thank you very much for your help !
I have 2 sheets.
For the first one (ActiveSheet), I have a list.
For example :
Beurre
Creme fraiche
Fromage
Oeufs
Yaourts
In the second one ("Add value"), I have this list :
Chocolat
Carotte
Haricot
Fromage
Endive
I want the script to verify if the first value which is the sheet ("Add Value") exists in the ActiveSheet.
If it doesn't, it takes the second value in "Add Value" to make this verification. And so on with the other lines.
The loop has to stop when the script finds the same value. Then it does an action (MsgBox, for example).
For example, when the script researches "Chocolat" (the first line of the sheet "Add Value") in the ActiveSheet, it won't find it : it will use the second word to make this reasearch until it uses world "Fromage" which also exist in the second sheet.
It does the action (the msgbox), then quit the loop to continue with the other called macro which are in the script.
Moreover, I would like to choose the columns of the cell from "Add Value" each time I call the macro. Indeed, there will be several lists in this sheet.
Here is my macro. The issue is that I get the error 424 on the ligne If Not FindString Is Nothing Then
Public Sub Var()
Dim plage As Variant
Set plage = ActiveSheet.Range("A:A")
Dim col As Integer
Dim Ligne As Integer
Set Ligne = 2
Dim FindString As String
Set FindString = ThisWorkbook.Sheets("Add Value").Cells(Ligne, col).Value
End Sub
Sub Boucle_Ajout(col)
With plage
Do
If Not FindString Is Nothing Then
'do
Else
Ligne = Ligne + 1
End If
Loop While Not FindString Is Nothing
End With
End Sub
Then when I call the Macro, I only have to choose the column.
For example :
Call Boucle_Ajout(1)
Thank you very much for your help, because I am sick of not finding the solution.
PS : sorry for my english, I'm french.
Assuming the lines without numbers are in A1 to A5, this works:
Option Explicit
Const THECOLUMN = "A1"
Sub FindLineInOtherSheet()
Dim activeSheetRange As Range
Dim addValueRange As Range
Dim activeSheetLastRow As Integer
Dim addValueLastRow As Integer
Dim i As Integer
Dim n As Integer
Dim activeSheetCell As String
Dim addValueCell As String
'*
'* Setup
'*
Set activeSheetRange = ThisWorkbook.Sheets("activeSheet").Range(THECOLUMN)
activeSheetLastRow = findLastRow("activeSheet", THECOLUMN)
addValueLastRow = findLastRow("addValue", THECOLUMN)
'*
'* Loop through each cell in addValue for each cell in activeSheet
'*
For i = 1 To activeSheetLastRow
Set addValueRange = ThisWorkbook.Sheets("addValue").Range(THECOLUMN)
activeSheetCell = activeSheetRange.Value
For n = 1 To addValueLastRow
addValueCell = addValueRange.Value
If addValueCell = activeSheetCell Then
MsgBox ("Trouvé " & addValueCell)
End If
Set addValueRange = addValueRange.Offset(1, 0) 'Next row
Next n
Set activeSheetRange = activeSheetRange.Offset(1, 0)
Next i
End Sub
Function findLastRow(Sheetname As String, ColumnName As String) As Integer
Dim lastRow As Integer
Dim r As Range
Dim WS As Worksheet
Set WS = Worksheets(Sheetname)
lastRow = WS.UsedRange.Rows.Count
'*
'* Search backwards till we find a cell that is not empty
'*
Set r = WS.Range(ColumnName).Rows(lastRow)
While IsEmpty(r)
Set r = r.Offset(-1, 0)
Wend
lastRow = r.Row
Set WS = Nothing
findLastRow = lastRow
End Function
I been struggling with a word macro that deletes Empty lines where a "$" exists. The code below works but only for the selected table, how can I have the code loop through the entire document and delete empty lines from all pages.
Option Explicit
Sub TEST()
Dim i As Long
With Selection.Tables(1)
For i = .Rows.Count To 1 Step -1
If Len(.Cell(i, 2).Range.Text) = 3 And Left(.Cell(i, 2).Range.Text, 1) = "$" Then
.Rows(i).Delete
End If
Next i
End With
End Sub
This is not tested on the same data-set as OP has since it is not provided.
Option Explicit
Sub TEST()
Dim tbl As Table
Dim mDoc As Document
Dim oRow As Row
Set mDoc = ActiveDocument
For Each tbl in mDoc.Tables
For Each oRow In tbl.Rows
If Len(oRow.Cells(2).Range.Text) = 3 And _
Left(oRow.Cells(2).Range.Text, 1) = "$" Then
oRow.Delete
End If
Next oRow
Next tbl
End Sub
I have a named range lstVendors that refers to: =OFFSET(Data!$W$2,0,0,COUNTA(Data!$W$2:$W$400),1). I want this range to be populated when the workbook opens. I have the following code for this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Range("lstVendors").Offset(0, 0).Value = "Please Select..."
' Set DropDown1 = ThisWorkbook.Sheets("Dashboard").DropDowns("Drop Down 1")
' DropDown1.Value = 1
On Error Resume Next
If Not IsError(Range("lstVendors")) Then
Range("lstVendors").ClearContents
End If
On Error GoTo 0
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
Set startRng = Range("lstVendors")
i = 0
For n = 2 To UBound(rslt)
Range("lstVendors").Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
It errors on the Set startRng = Range("lstVendors"). I know this is because there's nothing in the range when I'm trying to set it, because if I put one entry into the named range, the set works, however, I need it populated by the sqlite query on each open as the data changes.
Any suggestions much appreciated.
Try this. You have a dynamic range that doesn't evaluate after you clear the contents. To avoid this, there are probably several ways, but easy to simply hardcode the startRange variable so that it always points to Data!$W$2 address, which is (or rather, will become) the first cell in your lstVendors range.
Private Sub Workbook_Open()
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
Dim rngList As Range
'// Define your startRange -- always will be the first cell in your named range "lstVendors"
' hardcode the address because the dynamic range may not evalaute.
Set startRange = Sheets("Data").Range("W2")
'// Empty th lstVendors range if it exists/filled
On Error Resume Next
Range("lstVendors").Clear
On Error GoTo 0
'// Run your SQL query
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
i = 0
'// Print results to the Worksheet, beginning in the startRange cell
For n = 2 To UBound(rslt)
'Increment from the startRange cell
startRange.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
'Verify that "lstVendors" is being populated
Debug.Print Range("lstVendors").Address
Next n
End Sub
Thanks for the suggestions. Here is what I ended up doing in order to get around my problem. It involves adding something I didn't specify would be ok in my original question, so David's answer is great if what I did isn't an option. I first populated the first two cells in my named range with "Please Select..." and "All". In Sub Workbook_Open() we do this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
' Disable our not found message
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Set our start range to our named range
Set startRng = Range("lstVendors")
' Grab all vendor names
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
' Print result. Skip first two rows as constants "Please Select..." and "All" are populated there
i = 2
For n = 2 To UBound(rslt)
startRng.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
Then we will create Sub Workbook_BeforeClose:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Disable the save changes dialog. This workbook will be locked up for display only. No need to confuse the user.
Application.DisplayAlerts = False
' Clear everything below the "Please Select..." and "All" cells in the named range
On Error Resume Next
Range("lstVendors").Offset(2, 0).ClearContents
On Error GoTo 0
' Save the changes to the named range
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub
This information is going to populate a drop down, so having Please Select and All hardcoded into the named range is acceptable for me. If that stipulation doesn't work for someone else looking at this in the future, please use David's suggestion! Thanks again!