I have to create a large number (1000-5000) of hyperlinks in word with VBA. This procedure is necessary every time the document is started. I'd like to speed up my code.
Sub CreateHyperlinks(raHypers() As Range, saSubaddresses() As String, saScreentips() As String)
Dim i As Integer
Application.Visible = False
Application.ScreenUpdating = False
With ActiveDocument.Hyperlinks
For i = 0 To UBound(raHypers)
.Add raHypers(i), , saSubaddresses(i), saScreentips(i)
Next i
End With
End Sub
The array raHypers() is already sorted by the start property of the range variable in ascending order. I have already tried different things, but the code still takes quite long. Has anybody an idea how to speed it up?
did you tried a "for each" loop instead of your loop?
Sub CreateHyperlinks()
Dim myHyperlink As Hyperlink
For Each myHyperlink In ActiveDocument.Hyperlinks
*your code*
Next myHyperlink
End Sub
Edit1:
I missunderstood your question at 1st read, but you can use it nevertheless.
You just have to access the range of your hyperlinks with a "for each" loop instead of looping through it with an index.
This could speedup your code.
Sub CreateHyperlinks( _
raHypers() As Range, _
saSubaddresses() As String, _
saScreentips() As String)
Dim myRange As Range
For Each myRange In raHypers
' your code
Next myRange
End Sub
Edit:
Sry, i have no further ideas to speedup your code.
Related
Im trying to store the CurrentWorksheet name in order to reference it in a different Sub routine.
The code I currently have is as follows:
Private Sub InsertNewBill_Click()
Dim rng As Range
Set rng = Worksheets(CurrentWorksheet).Range("A30:L30")
rng.Insert Shift:=xlDown
End Sub
Current Worksheet Function:
Function CurrentWorksheet()
CurrentSheet = Application.Caller.Worksheet.Name
End Function
I need to try to reference the "CurrentSheet" variable in the "InsertNewBill" Sub routine.
The function of this is to insert a new line of cells between "A30:L30" on the currently selected worksheet.
Thanks in advance
I didn't plan to write this as answer, but to explain to Batteredburrito how to deal with objects rather than names:
Option Explicit
Private Sub InsertNewBill_Click()
Dim rng As Range
Set rng = currentWorksheet.Range("A31:AC31")
rng.Insert Shift:=xlDown
End Sub
Current Worksheet Function
Function currentWorksheet() As Worksheet
set currentWorksheet = ActiveSheet
End Function
This is doing exactly the same as your version (so you can stick with that), it's just to show how to deal with objects. But there are situations where it is much better to deal with objects that with name - especially if you are dealing with multiple Workbooks (that might have the same sheet names).
And, of course, in the end you could get rid of the function completely by simply writing
...
Set rng = ActiveSheet.Range("A31:AC31")
...
Thank you all for your help and direction.
I have resolved the issue with the following
Insert new cells between a range of cells on button press:
Private Sub InsertNewBill_Click()
Dim rng As Range
Set rng = Worksheets(CurrentWorksheet).Range("A31:AC31")
rng.Insert Shift:=xlDown
End Sub
Current Worksheet Function:
Function CurrentWorksheet()
CurrentWorksheet = ActiveSheet.Name
End Function
I am trying to use a combobox in my user interface, but if none of the options are good for the user they can type it in but after if they have entered something I want to save it so next time it appears in the list. I have tried the following approach:
For i = Range("O3") To Range("O3").End(xlDown)
If Not i.Value = ComboType.Value Then
Range("O3").End(xlDown) = ComboType.Value
End If
Next i
But this gives the above error on the first line. I am not very familiar with For loops in VBA so I am hoping somebody can help me.
This is how to make the for-each loop from O3 to the last cell with value after O3:
Public Sub TestMe()
Dim myCell As Range
Dim ws As Worksheet
Set ws = Worsheets(1)
With ws
For Each myCell In .Range("O3", .Range("O3").End(xlDown))
Debug.Print myCell.Address
Next myCell
End with
End Sub
It is a good practise to declare the worksheet as well, because otherwise you will always work with the ActiveSheet of the ActiveWorkbook.
I created the following macro in VBA but when I call it nothing happens. Any ideas why this might not work?
Sub RemoveWords(DeleteFromCol As Range, FindCol As Range)
Dim words As New Collection
Dim r As Range
Dim word As Variant
For Each r In FindCol
words.Add (r.Value2)
Next r
For Each r In DeleteFromCol
For Each word In words
r.Value2 = Replace(r.Value2, word, "")
Next word
Next r
End Sub
Sub Remove()
RemoveWords Range("A1:A233"), Range("B1:B5")
End Sub
Macro does not work because perhaps you are not passing mandatory arguments:
(DeleteFromCol As Range, FindCol As Range)
Is that correct?
Got it work now. It was due to having cells with multiple words in them. You have to split cells up to contain 1 word each and it runs fine.
I made a VBA macro that has the goal of doing several find and replaces on a database using a set of items in a table. I used a for each loop to try to iterate through each cell in the first column, but it only executes a find and replace on the items in the first column.
The table has two columns, "Replace What" and "Replace With" so i used find and replace to look for the item in the first column and used the offset function to replace it with the corresponding item in the next column.
How can I make this loop work?
Thanks
Here's my code:
Sub FindReplace()
Dim RepList As Range, RepItem As Range
Set RepList = Worksheets("Supply Replacement").Range("Table4[Replace What]")
For Each RepItem In RepList.Cells
Cells.replace What:=RepList.Value, Replacement:=RepList.Offset(0, 1).Value
Next RepItem
End Sub
Within your loop you should be working with RepItem, not RepList:
Sub FindReplace()
Dim RepList As Range, RepItem As Range
Set RepList = Worksheets("Supply Replacement").Range("Table4[Replace What]")
For Each RepItem In RepList.Cells
Cells.replace What:=RepItem.Value, Replacement:=RepItem.Offset(0, 1).Value
Next RepItem
End Sub
I've looked at the documentation for table cell objects and selection objects in VBA, and I didn't see any way to delete cell contents in Word while retaining the cell itself. It looks like doing so is easy in Excel, and next to impossible in Word.
Some cells I need to do this for will contain text, others will contain text form fields. Any ideas?
This works:
ActiveDocument.Tables(1).Cell(1, 2).Select
Selection.Delete
This deletes the cell contents but leaves the empty cell behind.
I understand your dismay, because oddly, the above does not do the same as
ActiveDocument.Tables(1).Cell(1, 2).Delete
which deletes the entire cell!
The former is the equivalent of selecting a cell and pressing the Delete key (which clears the contents but leaves the cell in place). The latter is the equivalent of right-clicking a cell and choosing "Delete cells..." (which deletes the cell).
I cobbled this together from various parts of the interwebs... including Fumei from VBA Express. It's working well. Select any cells in your table and run the macro deleteTableCells
Sub deleteTableCells()
Dim selectedRange As Range
On Error GoTo Errorhandler
Set selectedRange = SelectionInfo
selectedRange.Delete
Errorhandler:
Exit Sub
End Sub
Function SelectionInfo() As Range
'
Dim iSelectionRowEnd As Integer
Dim iSelectionRowStart As Integer
Dim iSelectionColumnEnd As Integer
Dim iSelectionColumnStart As Integer
Dim lngStart As Long
Dim lngEnd As Long
' Check if Selection IS in a table
' if not, exit Sub after message
If Selection.Information(wdWithInTable) = False Then
Err.Raise (2022)
Else
lngStart = Selection.Range.Start
lngEnd = Selection.Range.End
' get the numbers for the END of the selection range
iSelectionRowEnd = Selection.Information(wdEndOfRangeRowNumber)
iSelectionColumnEnd = Selection.Information(wdEndOfRangeColumnNumber)
' collapse the selection range
Selection.Collapse Direction:=wdCollapseStart
' get the numbers for the END of the selection range
' now of course the START of the previous selection
iSelectionRowStart = Selection.Information(wdEndOfRangeRowNumber)
iSelectionColumnStart = Selection.Information(wdEndOfRangeColumnNumber)
' RESELECT the same range
Selection.MoveEnd Unit:=wdCharacter, Count:=lngEnd - lngStart
' set the range of cells for consumption
With ActiveDocument
Set SelectionInfo = .Range(Start:=.Tables(1).cell(iSelectionRowStart, iSelectionColumnStart).Range.Start, _
End:=.Tables(1).cell(iSelectionRowEnd, iSelectionColumnEnd).Range.End)
End With
End If
End Function
Sorry for digging up such an old question, but hopefully someone will find this useful. If you prefer to avoid the Select method, the following is what you're looking for:
ActiveDocument.Tables(1).Cell(1, 1).Range.Text = ""
It deletes images and content controls as well.
Private Sub cbClearTable_Click()
'mouse cursor must be in the table for clearing
Dim cell_BhBp As Cell
For Each cell_BhBp In Selection.Tables(1).Range.Cells
cell_BhBp.Range = ""
Next
End Sub
The code above clears the contents in all cells in the current table /the table, where the mouse cursor is/
One other way to clear all table cells of first table in document is
ActiveDocument.Tables(1).Range.Delete
Or for current table /where the cursor is in/
Selection.Tables(1).Range.Delete
Private Sub CommandButton40_Click()
Application.Activate
SendKeys ("{DEL}")
End Sub
The code above clears contents of all selected cells. In this case, the selected cells may not be adjacent. This code is fired when button of user form is clicked.