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
Related
I am writing Word VBA that:
(1) assigns values from a Word table to VBA variables,
(2) cleans the variables' values of non-text,
(3) uses the variables' names and values to create Bookmarks in that same bookmark_value cell of the table, and
(4) repeats 1-2-3 until the end of table.
This table is the first table in the document and has two columns, something like this:
_________________________________
| bookmark_name | bookmark_value|
| bm1 | 88 |
| foo | 66 |
|_____bar_______|______44_______|
The code picks up the bookmark_names and posts into Word Bookmarks, and also picks up the bookmark_values but fails to clean the table coding out of the value.
The result is the Bookmarks displaying these unwanted cells in Word with the value inside it. It is strange that first column works and not the second.
Some things I tried:
I found on the Internet and on this site, what I thought were solutions, those are marked in the code below with comments, the header saying, "tried and failed".
I am nearly sure I need to "unformat" the text, or something like that.
Public Sub BookmarkTable()
Dim selectedTable As Table
Dim curRow As Range
Dim rngSelect1 As Range
Dim rngSelect2 As Range
Dim intTableIndex As Integer
Dim rng As Range
Dim Cell1 As Cell, Cell2 As Cell
Dim strBookmarkName As String, strBookmarkValue As String, strBV As String
Dim strTstBookmark As String
Dim Col1 As Integer, Col2 As Integer
Dim i As Integer, t As Integer
Dim intRow As Integer
' Dim
Col1 = 1 'set the bookmark name from column 1
Col2 = 2 'set the bookmark's value from column 2
'For t = 1 To ActiveDocument.Tables.Count
t = 1 'select the Table to use(only using the first table right now)
Set selectedTable = ActiveDocument.Tables(t)
selectedTable.Select 'selects the table
For intRow = 2 To selectedTable.Rows.Count 'iterate through all rows
If Selection.Information(wdWithInTable) Then
Set Cell1 = ActiveDocument.Tables(t).Cell(intRow, Col1)
Set Cell2 = ActiveDocument.Tables(t).Cell(intRow, Col2)
Cell2.Select
intTableIndex = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count
rngColumnStart = Selection.Information(wdStartOfRangeColumnNumber)
rngRowStart = Selection.Information(wdStartOfRangeRowNumber)
End If
strTstBookmark = "BM_Table" & CStr(intTableIndex) & "_R" & CStr(rngRowStart) & "_C" & CStr(rngColumnStart)
' strBookmarkValue = strTstBookmark
Set rngSelect1 = ActiveDocument.Range(Start:=Cell1.Range.Start, End:=Cell1.Range.End - 1)
strBookmarkName = Strip(rngSelect1.Text)
Set rngSelect2 = ActiveDocument.Range(Start:=Cell2.Range.Start, End:=Cell2.Range.End - 1)
strBookmarkValue = Strip(rngSelect2.Text)
Set rng = ActiveDocument.Tables(intTableIndex).Cell(rngRowStart, rngColumnStart).Range
rng.End = rng.End - 1
'--------------------------------------------------------------------------
'tried and failed)
'--------------------------------------------------------------------------
'Stop
If ActiveDocument.Bookmarks.Exists(strBookmarkName) = True Then
ActiveDocument.Bookmarks(strBookmarkName).Delete
End If
If ActiveDocument.Bookmarks.Exists(strTstBookmark) = True Then
ActiveDocument.Bookmark(strTstBookmark).Delete
End If
ActiveDocument.Bookmarks.Add Name:=strTstBookmark
ActiveDocument.Bookmarks.Add Name:=strBookmarkName
ActiveDocument.Bookmarks(strBookmarkName).Range.Text = strBookmarkValue
Next intRow
'Next t
End Sub
'--------------------------------------------------------------------------
'tried and failed
Private Function Strip(ByVal fullest As String)
' fuller = Left(fullest, Len(s) - 2)
Strip = Trim(Replace(fullest, vbCr & Chr(7), ""))
End Function
'--------------------------------------------------------------------------
That's truly horrible code you're using. Try:
Sub BkMkDemo()
Application.ScreenUpdating = False
Dim r As Long, BkMkNm As String, BkMkTxt As String
With ActiveDocument
For r = 2 To .Tables(1).Rows.Count
BkMkNm = Split(.Tables(1).Cell(r, 1).Range.Text, vbCr)(0)
BkMkTxt = Split(.Tables(1).Cell(r, 2).Range.Text, vbCr)(0)
If Not .Bookmarks.Exists(BkMkNm) Then .Bookmarks.Add BkMkNm, .Range.Characters.Last
Call UpdateBookmark(BkMkNm, BkMkTxt)
Next
End With
Application.ScreenUpdating = True
End Sub
Sub UpdateBookmark(BkMkNm As String, BkMkTxt As String)
Dim BkMkRng As Range
With ActiveDocument
If .Bookmarks.Exists(BkMkNm) Then
Set BkMkRng = .Bookmarks(BkMkNm).Range
BkMkRng.Text = BkMkTxt
.Bookmarks.Add BkMkNm, BkMkRng
End If
End With
Set BkMkRng = Nothing
End Sub
If all you want to do is to apply the bookmark to the content of the second cell, you need nothing more complex than:
Sub BkMkDemo()
Application.ScreenUpdating = False
Dim r As Long, BkMkNm As String, BkMkRng As Range
With ActiveDocument
For r = 2 To .Tables(1).Rows.Count
BkMkNm = Split(.Tables(1).Cell(r, 1).Range.Text, vbCr)(0)
Set BkMkRng = .Tables(1).Cell(r, 2).Range
BkMkRng.End = BkMkRng.End - 1
.Bookmarks.Add BkMkNm, BkMkRng
Next
End With
Application.ScreenUpdating = True
End Sub
After a great deal of research and learning by this VBA neophyte, here is the solution that I finally got to work. I found the fix by accident on the Windows Dev Center at msdn dot microsoft dot com posted by Cindy Meister...thank you. Turns out there are a combination of three characters needing to be cleaned when extracting text from a Word table cell: Chr(10) & Chr(13), Chr(11).
I simplified the code using the suggestions of macropod above. Thank you.
Sub aBookmarkTable()
'
'a subroutine compiled by Steven McCrary from various sources
'on the Internet, to use values in the second column of the
'first table in a Word document to create Bookmarks in that second
'column, in place of the value input there.
'
'To use the macros, modify the values in the table and run the macro.
'Then place Field Code references in Word to use the Bookmarks.
'The Bookmarks can be seen through Word menu: Insert>Links>Bookmark
'
'The table has just two columns, looking something like this:
'_________________________________
'| bookmark_name | bookmark_value|
'| bm1 | 88 |
'| foo | 66 |
'|_____bar_______|______44_______|
'
'The code places each Bookmark in the second column of each row, using
'the name given in the first column.
'
'The two critical functions of the macro occur in these two lines of code:
' rngBM.End = rngBM.End - 1
' Strip = Replace(fullest, Chr(10) & Chr(13), Chr(11))
'
' both are explained below where they are used.
Application.ScreenUpdating = False
Dim rng1 As Range, rng2 As Range, rngBM As Range
Dim Cell_1 As Cell, Cell_2 As Cell
Dim strBMName As String, strBMValue As String
Dim r As Integer
Call RemoveBookmarks 'removing bookmarks helped to simlify the coding
With ActiveDocument
For r = 2 To .Tables(1).Rows.Count 'iterate through all rows
Set Cell_1 = ActiveDocument.Tables(1).Cell(r, 1)
Set Cell_2 = ActiveDocument.Tables(1).Cell(r, 2)
Cell_2.Select
Set rng1 = .Range(Cell_1.Range.Start, Cell_1.Range.End - 1)
strBMName = Strip(rng1.Text)
Set rng2 = .Range(Cell_2.Range.Start, Cell_2.Range.End - 1)
Set rngBM = ActiveDocument.Tables(1).Cell(r, 2).Range
'When using data contained in a cell of a Word table,
'grabbing the cell's contents also grabs several other
'characters, which therefore need removed in two steps.
'
'The first step is to clean the extra characters from the text.
strBMValue = Strip(rng2.Text)
'
'The second step is to decrease the range size to put in the
'Bookmark.
rngBM.End = rngBM.End - 1
rngBM.Text = strBMValue
.Bookmarks.Add strBMName, rngBM
Next r
End With
Application.ScreenUpdating = True
Selection.WholeStory
ActiveDocument.Fields.Update
End Sub
Sub RemoveBookmarks()
Dim bkm As Bookmark
For Each bkm In ActiveDocument.Bookmarks
bkm.Delete
Next bkm
End Sub
Private Function Strip(ByVal fullest As String)
' the next line of code is the tricky part of the clean
' process because of how Word formats tables and text
' ASCII code Chr(10) is Line Feed
' Chr(13) is Carriage Return
' Chr(13) + Chr(10): vbCrLf or vbNewLine New line character
' Chr (11) is Vertical Tab, but per Word VBA Manual -
' manual line break (Shift + Enter)
'
Strip = Replace(fullest, Chr(10) & Chr(13), Chr(11))
End Function
Thank you again.
SWM
I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows but when I try to apply the Hidden behavior on the whole row then VBA through an error.
Getting error on below the line
Selection.Font.Hidden = True
Below is my whole code
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\DE\DE\International_DE.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("French", "Spanish")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Select
Selection.Font.Hidden = True
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where i am doing issue so, i can rectify it.
I think it's more effective to reduce the row height to an exact minimum value.
Something like this works for me.
Sub Test()
SearchArr = Array("sdg", "sdh", "dsf")
'loop tables
For Cnt = 1 To ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each tblCell In ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = tblCell.Range
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).HeightRule = wdRowHeightExactly
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).Height = 1
End If
Next tblCell
Next Arrcnt
Next Cnt
End Sub
is there I way for searching a value on the next sheet (ActiveSheet.Next.Activate) without jumping on to it?
Here the whole Code:
the problem is, it jumps to the next sheet even if there is no searched value.
Dim ws As Worksheet
Dim Loc As Range
Dim StrVal As String
Dim StrRep As String
Dim i As Integer
Private Sub CommandButton1_Click()
i = 1
Call Replacing
End Sub
Private Sub CommandButton2_Click()
i = 2
Call Replacing
End Sub
Public Sub Replacing()
StrVal = Userform1.Textbox1.Text
StrRep = Me.Textbox1.Text
if Trim(StrVal) = "" Then Exit Sub
Dim fstAddress As String
Dim nxtAddress As String
For Each ws In ThisWorkbook.Worksheets
With ws
Set Loc = .Cells.Find(what:=StrVal)
fstAddress = Loc.Address
If Not Loc Is Nothing Then
If Not StrRep = "" And i = 1 Then
Loc.Value = StrRep
Set Loc = .Cells.FindNext(Loc)
ElseIf i = 2 Then Set Loc = Range(ActiveCell.Address)
Set Loc = .Cells.FindNext(Loc)
nxtAddress = Loc.Address
If Loc.Address = fstAddress Then
ActiveSheet.Next.Activate '****Here it should jump only if found something on the next sheet****
GoTo repeat
nxtAddress = Loc.Address
End If
If Not Loc Is Nothing Then Application.Goto ws.Range(nxtAddress), False
End If
i = 0
End If
End With
Set Loc = Nothing
repeat:
Next ws
End Sub
the variable "i" which switches between the values 0, 1 and 2 is bound to two buttons. these buttons are "Replace" and "Skip (to next found value)".
This code asks on each occurrence of StrVal whether you want to replace the value or skip it.
I found a problem checking if Found_Address = First_Found_Address:
If you've replaced the value in in First_Found_Address it won't find that address again and miss the starting point in the loop.
Also the original source of the code stops at the last value using Loop While Not c Is Nothing And c.Address <> firstAddress. The problem here is that if the value in c is being changed eventually c will be Nothing but it will still try and check the address of c - causing an error (Range Find Method).
My solution to this is to build up a string of visited addresses on the sheet and checking if the current address has already been visited using INSTR.
I've included the code for calling from a button click or from within another procedure.
Private Sub CommandButton1_Click()
FindReplace Userform1.Textbox1.Text, 1
End Sub
Private Sub CommandButton2_Click()
FindReplace Userform1.Textbox1.Text, 1, Me.Textbox1.Text
End Sub
Sub Test()
FindReplace "cd", 1, "ab"
End Sub
Sub FindReplace(StrVal As String, i As Long, Optional StrRep As String = "")
Dim ws As Worksheet
Dim Loc As Range
Dim fstAddress As String
Dim bDecision As Variant
For Each ws In ThisWorkbook.Worksheets
'Reset the visited address list on each sheet.
fstAddress = ""
With ws
Set Loc = .Cells.Find(what:=StrVal, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Loc Is Nothing Then
Do
fstAddress = fstAddress & "|" & Loc.Address
Loc.Parent.Activate 'Activate the correct sheet.
Loc.Activate 'and then the cell on the sheet.
bDecision = MsgBox("Replace value?", vbYesNo + vbQuestion, "Replace or Select value?")
If bDecision = vbYes Then
Loc = StrRep 'Raise the blade, make the change.
'Re-arrange it 'til it's sane.
End If
Set Loc = .Cells.FindNext(Loc)
If Loc Is Nothing Then Exit Do
Loop While InStr(fstAddress, Loc.Address) = 0
End If
End With
Next ws
End Sub
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
I have this Word VBA code, which removes field codes, but retains their values. This works well, but not in the header. How can I edit it to work for the body of document ( and header/footer as well ) ?
Sub RemoveFieldCodeButRetainValue()
Dim d As Document
Dim iTemp As Integer
Dim strTemp As String
Set d = ActiveDocument
For iTemp = d.Fields.Count To 1 Step -1
strTemp = d.Fields(iTemp).Result
d.Fields(iTemp).Select
With Selection
.Fields(1).Delete
.TypeText strTemp
End With
Next
End Sub
Sorry, I realize this isn't exactly the answer to the question, but using:
For Each fld In ActiveDocument.Fields
fld.Unlink
Next
will preserve the value while deleting the underlying field. As far as I know, you could use the same technique while looping through the various story ranges as suggested in the other answer for the header/footer areas.
ok, I got it:
Use two macros:
Sub CtrlAPlusFNine()
Selection.WholeStory
Dim oStory As Range
For Each oStory In ActiveDocument.StoryRanges
oStory.Fields.Update
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
oStory.Fields.Update
Wend
End If
Next oStory
lbl_Exit:
Set oStory = Nothing
Exit Sub
End Sub
Sub RemoveFieldCodeButRetainValue()
Dim d As Document
Dim iTemp As Integer
Dim strTemp As String
Set d = ActiveDocument
For iTemp = d.Fields.Count To 1 Step -1
strTemp = d.Fields(iTemp).Result
d.Fields(iTemp).Select
With Selection
.Fields(1).Delete
.TypeText strTemp
End With
Next
End Sub
..and call these two from a third macro using Application.Run