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
Related
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.
I am very new to VBA and there is a task I would like to automate and don't know where to start. I have a data set that looks like below.
Sample Data
What I'm trying to do is loop through column A and if it has something in it (will always be an email) select all rows until there is something in column A again. Copy and paste into new tab. So row 2-5 would copy and paste into a new tab. Then row 6-9 into a different new tab. Also row 1 would copy to each tab as well. I haven't been able to find code to help with this specific need and any help would be greatly appreciated.
I found this code and started modifying it but, it's nowhere close to what I need or working for that matter.
Sub split()
Dim rng As Range
Dim row As Range
Set rng = Range("A:A")
For Each row In rng
'test if cell is empty
If row.Value <> "" Then
'write to adjacent cell
row.Select
row.Copy
Worksheets("Sheet2").Activate
Range("A2").Select
row.PasteSpecial
Worksheets("Sheet1").Activate
End If
Next
End Sub
This code should provide what you need:
Sub Split()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets(1) 'change sheet index or use Worksheets("Sheet1") method to use exact name
Dim rngBegin As Range
Dim rngEnd As Range
With ws
Dim rngHeader As Range
Set rngHeader = .Range("A1:H1") 'to copy headers over each time
Dim lRowFinal As Long
lRowFinal = .Range("C" & .Rows.Count).End(xlUp).Row 'assumes eventually last row of needed data will have an address1
Set rngEnd = .Range("A1") ' to begin loop
Set rngBegin = rngEnd.End(xlDown) 'to begin loop
Do
Set rngEnd = rngBegin.End(xlDown).Offset(-1)
Dim wsNew As Worksheet
Set wsNew = Worksheets.Add(After:=wb.Sheets(.Index))'always after current sheet, change as needed
.Range(.Cells(rngBegin.Row, 1), .Cells(rngEnd.Row, 8)).Copy wsNew.Range("A2")
wsNew.Range("A1:H1").Value = rngHeader.Value
Set rngBegin = rngEnd.End(xlDown)
Loop Until rngBegin.Row >= lRowFinal
End With
End Sub
Try to break your process into steps and determine rules on how to proceed. Then write out some pseudo-code (code like logic) to make sure it all makes sense.
You need some sort of loop, since you are going to treat each
group of rows in the same way.
You need some code that determines what cells are contained in each block
Code to take a block (given by step 2) and paste it into a new tab.
Your Pseudo Code might look like this:
' This is the main function that runs the whole routine
Sub Main()
Set headerRg = GetHeaderRg()
Do Until IsAtTheEnd(startRow) = True
Set oneBlock = GetNextBlock(startRow)
Call ProcessBlock(oneBlock)
startRow = startRow + oneBlock.Rows.Count
Loop
End Sub
' This function returns the header range to insert into the top
Function GetHeaderRg() As Range
' Write some code here that returns the header range
End Function
' This function determines whether we are at the end of our data
Function IsAtTheEnd(current_row as Long) as Boolean
' Write some code here that determines whether we have hit the end of our data
'(probably checks the first column to see if there is data)
End Function
' This function takes the startRow of a block and returns the whole block of Rows
Function GetNextBlock(startRow) As Range
' Write some code that returns the whole range you want to copy
End Function
' This sub takes a range to be processed and a header to print and prints
' it into a new tab
Sub ProcessBlock(BlockRg As Range, headerRg as Range)
Set targetSheet = thisWorkbook.Sheets.Add()
' Write some code that pastes the headerRg and BlockRg where you want it
End Sub
If you start to have more specific questions about syntax etc, we will be happy to help here!
I have a value in a cell. This value is duplicated, intentionally, in another part of the worksheet. I would like to be able to click the cell in C5 with contents 12345 and it selects the cell in A1:1600 that contains the same value. I will never have more than 2 cells with this same value in the worksheet, but the values will change.
I appreciate any help you can offer.
Thank You.
This should do the trick - I was unsure of the range you wanted to specify, so I just put it as A1:Z1600, but change it as necessary.
In VBA, paste this into your sheet's code module:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim OriginalAddress As String
Dim ValToFind As String
Dim CurrentCell As Range
OriginalAddress = Target.Parent.Address
ValToFind = Target.Parent.Value
With Range("A1:Z1600")
Set CurrentCell = .Find(What:=ValToFind)
If OriginalAddress = CurrentCell.Address Then
.FindNext(After:=CurrentCell).Activate
Else
CurrentCell.Activate
End If
End With
End Sub
You can use the Hyperlink function to do what you wanting. But you would have to manually type out the formula for each cell that you wanted to link... Here's an example:
=HYPERLINK("[Book1]Sheet1!F2",12345)
This method is very unwieldy. The only way to do what you want in a robust fashion would be to use VBA.
Edit: I was able to duplicate the issue. The below edits seem to resolve the issue.
This VBA solution used the FindNext function to find the next value in the sheet:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim FirstAddress As String
Dim Rng As Range
Dim x As Long
x = Me.UsedRange.Rows.Count
FirstAddress = Target.Address
Set Rng = Me.UsedRange.Find(Target.Value)
If FirstAddress = Rng.Address Then
Me.UsedRange.FindNext(Rng).Select
Else
Rng.Select
End If
End Sub
This works with a double click for the sheet the code is in, and it doesn't matter where the duplicate value is in that sheet. Just place the code in your worksheet's module.
One last way to do this (although still inferior to VBA) is to insert the hyperlink:
In this example, you click on A2>go to Insert Tab>Hyperlink>Place in This Document and enter the corresponding cell. This hyperlinks cell A2 to F2 so that when A2 is selected F2 is selected.
In my active sheet called Report I have 2 column I & F.
It has repeating cells containing text "Grand Total".
I would like to delete whole row if it contains Grand Total automatically.
VBA code would be nice.
With the following VBA code, you can quickly delete the rows with certain cell value, please do as the following steps:
Select the range that you want to delete the specific row.
Click Developer>Visual Basic, a new Microsoft Visual Basic for applications window will be displayed, click Insert > Module, and input the following code into the Module:
VBA code to Remove entire rows based on cell value(i.e. Grand Total):
Sub Delete_Rows()
Dim rng As Range, cell As Range, del As Range
Set rng = Intersect(Range("A1:D22"), ActiveSheet.UsedRange)
For Each cell In rng
If (cell.Value) = "Grand Total" _
Then
If del Is Nothing Then
Set del = cell
Else: Set del = Union(del, cell)
End If
End If
Next cell
On Error Resume Next
del.EntireRow.Delete
End Sub
Then click "Play/Run" button to run the code, and the rows which have certain value have been removed.
(Note: If you can't see Developer Tab in Excel Do these Steps: 1)Click the Office Button, and then click Excel Options. 2)In the Popular category, under Top options for working with Excel, select the Show Developer tab in the Ribbon check box, and then click OK.)
Using AutoFilter is very efficient. This can also be done without VBA (ie manually)
Main Sub
Sub Main()
Dim ws As Worksheet
Dim rng1 As Range
Dim StrIn As String
Dim rng2 As Range
Set ws = Sheets("Sheet1")
Application.ScreenUpdating = False
Set rng1 = ws.Range("F:F,I:I")
StrIn = "Grand Total"
For Each rng2 In rng1.Columns
Call FilterCull(rng2, StrIn)
Next
Application.ScreenUpdating = True
End Sub
Delete Sub
Sub FilterCull(ByVal rng2, ByVal StrIn)
With rng2
.Parent.AutoFilterMode = False
.AutoFilter Field:=1, Criteria1:=StrIn
.EntireRow.Delete
.Parent.AutoFilterMode = False
End With
End Sub
This should help get you started.
http://msdn.microsoft.com/en-us/library/office/ee814737%28v=office.14%29.aspx#odc_Office14_ta_GettingStartedWithVBAInExcel2010_VBAProgramming101
Also see similar question:
Delete a row in Excel VBA
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.