In a Word file I need to copy only a portion of a footnote, let's say from char 2 to 8. The following code doesn't work.
Dim rng As Range
Set rng = ActiveDocument.Footnotes(1).Range.Duplicate
rng.SetRange(2, 8) 'compilation error, also those indexes refer to the main story
Set rng = rng.Document.Range(2, 8) 'compile, but those indexes refer to the main story
rng.Copy
ActiveDocument.Footnotes(1).Range.Start is 2. But when you set the Range to 2 it points to the main story.
How can I do that?
Thanks
For example:
Sub Demo()
Dim Rng As Range
Set Rng = ActiveDocument.Footnotes(1).Range
With Rng
.Start = .Start + 2
.End = .Start + 6
MsgBox .Text
End With
End Sub
Related
Below is my attempt but it's producing odd results, and the results seem to change each time i run the macro...
Can anyone see any issues in my code or can think of a better way of doing this?
Sub ConvertTablesToImages()
Dim tbl As Table
Dim currentDoc As Document
Set currentDoc = ActiveDocument
For Each tbl In currentDoc.Tables
tbl.Range.Copy
Selection.Collapse Direction:=wdCollapseStart
Selection.PasteSpecial DataType:=wdPasteEnhancedMetafile
tbl.Delete
Next
End Sub
You had a few problems. One is mixing ranges and selections and the other is deleting members of a collection (in this case tables in the document) while trying to loop through all of them.
Take a look at this revision of your code. It should work better.
Sub ConvertTablesToImages()
Dim tbl As Table, rng As Range, i As Integer
Dim currentDoc As Document
Set currentDoc = ActiveDocument
For i = currentDoc.Tables.Count To 1 Step -1
Set tbl = currentDoc.Tables(i)
Set rng = tbl.Range
rng.Collapse Direction:=wdCollapseStart
tbl.Range.CopyAsPicture
tbl.Delete
rng.PasteSpecial DataType:=wdPasteEnhancedMetafile
rng.ShapeRange(1).ConvertToInlineShape
Next
End Sub
Just adding a variation to Rich's answer for anyone who finds that their tables are being cropped in some of the pasted images.
Adding tbl.PreferredWidth = 0 seemed to fix this
Sub ConvertTablesToImages()
Dim tbl As Table, rng As Range, i As Integer
Dim currentDoc As Document
Set currentDoc = ActiveDocument
For i = currentDoc.Tables.Count To 1 Step -1
Set tbl = currentDoc.Tables(i)
Set rng = tbl.Range
tbl.PreferredWidth = 0
rng.Collapse Direction:=wdCollapseStart
tbl.Range.CopyAsPicture
tbl.Delete
rng.PasteSpecial DataType:=wdPasteEnhancedMetafile
rng.ShapeRange(1).ConvertToInlineShape
Next
End Sub
i am still trying to fix a problem with a table in word. In my table are three columns and many rows. In the row an explanatory text is written in italic. Now I want to delete rows in the tables of my worddocument where the font is italic.
I tried to use the macro recorder but it wont work. I would really appreciate your help.
For that you might use a macro like:
Sub Demo()
Application.ScreenUpdating = False
Dim r As Long, Rng As Range
With Selection
If .Information(wdWithInTable) = False Then Exit Sub
With .Tables(1)
For r = .Rows.Count To 1 Step -1
Set Rng = .Cell(r, 1).Range
With Rng
.End = .End - 1
If .Font.Italic = True Then .Rows(1).Delete
End With
Next
End With
End With
Application.ScreenUpdating = True
End Sub
where the 1 in .Cell(r, 1).Range indicates the column # of the italicised text.
Have a column H with alphanumeric characters. Some cells in this column have the content (RAM) followed by 5 digits starting from 00000 to 99999.
If cell H219 has the content (RAM) 23596 then i have to fill cell A219 with a comment "completed".
This has to be done for all cells with the content "(RAM) followed by 5 digits"
Sub Macro16_B()
' ' Macro16_B Macro ' '
intRowCount = Worksheets("Reconciliation").UsedRange.Rows.Count
For i = 11 To intRowCount
If InStr(Range("H" & i).Value, "(RAM 00000-99999") Then
Range("A" & i).Value = "Completed"
End If
Next i
End Sub
A non-VBA answer could be (if the cell doesn't have extra text other than (RAM) & 5 numbers):
=IFERROR(IF(LEN(VALUE(TRIM(SUBSTITUTE(H1,"(RAM)",""))))=5,"completed",""),"")
My VBA answer would be:
Sub Test()
Dim rLastCell As Range
Dim rCell As Range
With Worksheets("Reconciliation")
Set rLastCell = .Columns(8).Find("*", , , , xlByColumns, xlPrevious)
If Not rLastCell Is Nothing Then
For Each rCell In .Range(.Cells(1, 8), rLastCell)
If rCell Like "*(RAM) #####*" Then
rCell.Offset(, -7) = "complete"
End If
Next rCell
End If
End With
End Sub
Cheers #Excelosaurus for heads up on the * would've forgotten it as well. :)
One way is to use the Like operator. The precise format of your string is not clear so you may have to amend (and assuming case insensitive). # represents a single number; the * represents zero or more characters.
Sub Macro16_B()
Dim intRowCount As Long, i As Long
' ' Macro16_B Macro ' '
intRowCount = Worksheets("Reconciliation").UsedRange.Rows.Count
For i = 11 To intRowCount
If Range("H" & i).Value Like "(RAM) #####*" Then
Range("A" & i).Value = "Completed"
End If
Next i
End Sub
Well, there are already 2 good answers, but allow me to paste my code here for good measure, the goal being to submerge #user2574 with code that can be re-used in his/her next endeavors:
Sub Macro16_B()
'In the search spec below, * stands for anything, and # for a digit.
'Remove the * characters if you expect the content to be limited to "(RAM #####)" only.
Const SEARCH_SPEC As String = "*(RAM #####)*"
Dim bScreenUpdating As Boolean
Dim bEnableEvents As Boolean
'Keep track of some settings.
bScreenUpdating = Application.ScreenUpdating
bEnableEvents = Application.EnableEvents
On Error GoTo errHandler
'Prevent Excel from updating the screen in real-time,
'and disable events to prevent unwanted side effects.
Application.ScreenUpdating = False
Application.EnableEvents = False
'Down with business...
Dim scanRange As Excel.Range
Dim cell As Excel.Range
Dim content As String
Dim ramOffset As Long
With ThisWorkbook.Worksheets("Reconciliation").Columns("H")
Set scanRange = .Worksheet.Range(.Cells(11), .Cells(.Cells.Count).End(xlUp))
End With
For Each cell In scanRange
content = CStr(cell.Value2)
If content Like SEARCH_SPEC Then
cell.EntireRow.Columns("A").Value = "Completed"
End If
Next
Recover:
On Error Resume Next
'Restore the settings as they were upon entering this sub.
Application.ScreenUpdating = bScreenUpdating
Application.EnableEvents = bEnableEvents
Exit Sub
errHandler:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
Resume Recover
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!
I cobbled together this a few years ago and now I need it tweaked slightly but I'm very rusty with VBA so could do with some advice:
Sub Colour_Cells_By_Criteria()
Dim myRange As Range
Dim myPattern As String
Dim myLen As Integer
Dim myCell As Range
Set myRange = Range("A1:A1000")
myPattern = "*1*"
myLen = 4
Application.ScreenUpdating = False
Application.StatusBar = "Macro running, please wait...."
For Each myCell In myRange
With myCell
If (.Value Like myPattern) And (Len(.Value) = myLen) Then
myCell.Interior.Color = 65535
myCell.Font.Bold = True
End If
End With
Next
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Rather than colouring and bolding any cells that are captured by the logic, I'd like to put the word "MATCH" in the same row in column B.
Any nudges in the right direction would be appreciated.
myCell.Offset(0,1).Value="Match"