Erase all the content after a specific word - excel

I want to use VBA to 1) Find the word “Report:” in my excel sheet (I know the word “Report:” will only appear once in the sheet); 2) Erase all the content (including the word “Report”) below this cell
So, ideally, the result should look like this:
The amount of data will change, so the word “Report:” is not going to be in the row 109 every time.
This is the code I am using now,
Sub Trial()
Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="Report:", _
Forward:=True
If myRange.Find.Found = True Then
myRange.SetRange (myRange.End + 1), ActiveDocument.Content.End
myRange.Delete
End If
End Sub
But, it gives me a
run-time error ‘424’

Give this a try:
Option Explicit
Sub ReportKiller()
Dim Report As String, r As Range, rKill As Range
Report = "Report"
Set r = Cells.Find(Report, after:=Cells(1, 1))
If Not r Is Nothing Then
Set rKill = Range(r, r.End(xlDown))
rKill.EntireRow.Delete
End If
End Sub
It will delete all sheet content from the Report cell downward.

Related

VBA losing links

Manual - Select range, execute Sub
How it works - Sub saves all non-blank cells to finalArray that is ultimately displayed in the selected range
What's the problem - if range contains cells with hyperlinks created via insert-hyperlink, the hyperlinks disappear.
Sub RemoveBlanks()
'i,j - counters, k - offset
Dim finalArray() As Variant
ReDim finalArray(Selection.Rows.Count, 1)
k = 1
For i = 1 To Selection.Rows.Count
If Selection(i, 1) <> "" Then
finalArray(k, 1) = Selection(i, 1)
k = k + 1
End If
Next i
Application.ScreenUpdating = False
Application.EnableEvents = False
Selection.Clear
For i = 1 To k
Selection(i, 1).Value = finalArray(i, 1)
Next i
End Sub
This Code will loops through each cell in the selected range, checks if the cell has a hyperlink then temporarily grab and store the address that it’s pointing to re-apply the hyperlink
Option Explicit
Sub fixHyperlinks()
Dim rng As Range
Dim address As String
Application.ScreenUpdating = False
For Each rng In Selection
If rng.Hyperlinks.Count > 0 Then
address = rng.Hyperlinks(rng.Hyperlinks.Count).address
rng.Hyperlinks.Add Anchor:=rng, _
address:=address
End If
Next
Application.ScreenUpdating = True
End Sub
After you run this code, you should be able to set in your array the range without losing your links.
Conclusion : Run this code before you run your macro.
So I have found a way around the issue after lurking through internet and trying to save links in another array (fails). It works only if the value in the cell is the same as name of a sheet, yet it solves my issue so far.
Sub CreateLinks()
'i - counter, the title as i=1 is omitted. Code uses value stored in cell to
'transform it into a link.
Dim i As Integer
For i = 2 To Selection.Rows.Count
If Selection(i) <> "" Then
ActiveSheet.Hyperlinks.Add anchor:=Selection(i), _
address:="#'" & CStr(Selection(i)) & "'!A1", _
TextToDisplay:=CStr(Selection(i))
End If
Next i
End Sub

How do I fill a series using VBA?

I'm trying to get my code to search column D for cells that are not blank. When it finds one that isn't blank it copies that cell and fills the series beneath. Then I want it to repeat this code until "D3020".
However each time I run my code it takes the copied cell and continuously pastes it all the way down to "D3020". There are different values that also need to be copied so I need to fix this. I have tried using the .offset property. I have tried using .range.copy property.
Sub Fill()
Dim SRng As Range
Dim SCell As Range
Set SRng = Range("D1101:D3020")
For Each SCell In SRng
If SCell <> "" Then
SCell.Copy
Range(SCell, SCell.Offset(10, 0)).PasteSpecial(xlPasteAll)
End If
Next SCell
End Sub
I'd like this code to search Range("D1101:D3020") for cells that <> "". When one is found, fill the series beneath it, stopping at the next cell with a number in it.
For example
D1101 = 1601166 (see picture) I want to copy this and fill the series beneath it. All are exactly ten rows apart. Then D1121 = 1601168 (see picture) I want to copy/fill series for this as well.
No need for a loop; just fill the blanks with the value above.
sub fillBlanks()
dim brng as range
on error resume next
set brng = Range("D1101:D3020").specialcells(xlcelltypeblanks)
on error goto 0
if not brng is nothing then
brng.formular1c1 = "=r[-1]c"
Range("D1101:D3020") = Range("D1101:D3020").value
end if
end sub
Option Explicit
Sub Test()
FillEmptyFromTop [D1101:D3020]
End Sub
Sub FillEmptyFromTop(oRng As Range)
Dim v, a, i
With oRng.Columns(1)
a = .Value
For i = LBound(a, 1) To UBound(a, 1)
If IsEmpty(a(i, 1)) Then a(i, 1) = v Else v = a(i, 1)
Next
.Value = a
End With
End Sub

I need vBA coe to replace a list of strings in an Excel sheet with another string

I need code like this in VBA
Sub ReplaceCourseCode()
if(string in a cell= "john")
replace string in a cell with "ThunderJohn"
elseif(string in a cell ="David)
replace string in a cell with "ThunderDavie"
else move to next cell
End Sub
Either of the two procedures below will do what you want. The second one will work faster because it doesn't reference the worksheet as often as the first, but it also uses a different system of setting up the comparison. You might mix the methods and systems to best suit the environment in which you want the job to be done.
Option Explicit
Sub ChangeName_1()
Const Target As String = "B2:B100" ' change as required
Dim Cell As Range
Application.ScreenUpdating = False
For Each Cell In ActiveSheet.Range(Target)
With Cell
If StrComp(Trim(.Value), "john", vbTextCompare) = 0 Then
.Value = "ThunderJohn"
ElseIf StrComp(Trim(.Value), "David", vbTextCompare) = 0 Then
.Value = "ThunderDavid"
End If
End With
Next Cell
Application.ScreenUpdating = True
End Sub
Sub ChangeName_2()
Const Target As String = "B2:B100" ' change as required
Dim Cell As Range
Dim Txt As String
Application.ScreenUpdating = False
For Each Cell In ActiveSheet.Range(Target)
With Cell
Txt = Trim(LCase(.Value))
If Len(Txt) Then
If InStr(1, "john,david", Txt, vbTextCompare) Then
.Value = "Thunder" & UCase(Left(Txt, 1)) & Mid(Txt, 2)
End If
End If
End With
Next Cell
Application.ScreenUpdating = True
End Sub
As with most tasks in VBA, there are numerous different methods that can yield the same result. Here's a couple...
This one loops through the cells you specify, or you could replace Range("A1:B3") with ActiveSheet.UsedRange to loop through all "used" cells on the worksheet:
Sub ReplaceCourseCode()
Dim c As Range
For Each c In Range("A1:B3") 'specify the search range (on the active worksheet)
If c = "john" Then
c = "ThunderJohn"
ElseIf c = "David" Then
c = "ThunderDavie"
End If
Next c
End Sub
Or, if you're just looking to automate simple Search & Replace (like CTRL+H) for the whole worksheet, you only need one line of code per search:
Sub FindReplace()
Cells.Replace What:="john", Replacement:="ThunderJohn", MatchCase:=False
Cells.Replace What:="David", Replacement:="ThunderDavie", MatchCase:=False
End Sub
Further reading:
Range.Replace Method
Replace Function
RegEx Tutorial (a Beginner's guide to Advanced searching)

How to overcome the limit of hyperlinks in Excel?

I have a list of links in more than 100000 cells.
I have to give hyperlinks to all of them but in Excel there is a limit of 65530 hyperlinks per worksheet.
How can I overcome the limit or how can I merge cells with equal values using VBA?
Sub AddHyperlinks()
Dim myRange As Range
Set myRange = Range("A1")
Dim hText As Variant
Do Until IsEmpty(myRange)
hText = Application.VLookup(myRange.Value, Worksheets("Sheet2").Range("A:B"), 2, False)
If IsError(hText) Then
hText = ""
Else
ActiveSheet.Hyperlinks.Add Anchor:=myRange, Address:="http://" + hText, TextToDisplay:=myRange.Text
hText = ""
End If
Set myRange = myRange.Offset(1, 0)
Loop
End Sub
The solution is as mentioned by #Rory:
Use the HYPERLINK function in your cell to emulate a hyperlink via a formula.
=HYPERLINK(url, displaytext)
This effectively bypasses the built-in Excel limit on "hard-coded" hyperlinks. Just tested this out after I hit the infamous error 1004:
Application-defined or object-defined error
when trying to create 100k+ hyperlinks in a sheet.
Just regular copy paste should work, but I can update the example (not tested) if it doesn't
Sub AddHyperlinks()
Dim rng As Range, rngFrom As Range, values, r
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1")
Set rngFrom = ThisWorkbook.Worksheets("Sheet2").Range("A:A")
rng.Worksheet.Hyperlinks.Delete ' remove all previous Hyperlinks
While rng(1) > ""
' resize the range to the same values
While rng(rng.Rows.Count + 1) = rng(1)
Set rng = rng.Resize(rng.Rows.Count + 1)
Wend
r = Application.Match(rng(1), rngFrom, 0)
If Not IsError(r) Then
values = rng.Value2 ' save the values
rngFrom(r, 2).Copy rng ' copy from the cell next to the match
rng.Value2 = values ' restore the values (not sure if it removes the links)
End If
Set rng = rng(rng.Rows.Count + 1) ' move to the next cell below
Wend
End Sub
If you store the URL in (eg) colA then something like this should work:
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim URL
If Target.Column <> 1 Then Exit Sub '<< only reacting if cell in URL column is right-clicked
URL = Target.Value
ThisWorkbook.FollowHyperlink URL
End Sub
Alternatively use the Before_DoubleClick event
It does mean you can't use a "friendly" link text such as "click here", but you could likely manage that if you store the URL text at a fixed offset and then read that instead of Target.Value
I suffered from the same problem and I know that I shouldn't have more than around 120000 rows that need hyperlinking so modified some code I found in another thread to this
Sub hyperlink2()
Dim Cell As Range
Dim Cell2 As Range
Dim rng As Range
Dim Rng2 As Range
Set rng = Range("X2:X60000")
For Each Cell In rng
If Cell <> "" Then ActiveSheet.Hyperlinks.Add Cell, Cell.Value
Next
Set Rng2 = Range("X60001:X120000")
For Each Cell2 In Rng2
If Cell2 <> "" Then ActiveSheet.Hyperlinks.Add Cell2, Cell2.Value
Next
End Sub
Hope that helps someone else who stumbles upon this via google (like I did) looking for a workable solution...
The 255 character limit applies to the limit of character that can be put in one cell's formula. A common approach to this is by splitting the link into multiple cells and using a formula to combine them.
=HYPERLINK(A1&A2,"Click Here")

Excel VBA or not to VBA, replace text if different between two cells

I have a quandary, and I don't know if it will work better using excel VBA or not. Thinking about it I believe VBA will work best, but I don't know how to make it work.
I have two pages in a workbook, one is the form, the other is the database, I want the pulldown menu from the form to populate the rest of the form. It does... what I want then is to be able to change the value of the form press submit, and the new data will overwrite the old data.
Is this possible?
Here is the link to the sheet I'm talking about.
http://dl.dropbox.com/u/3327208/Excel/Change.xlsx
Here is the script I am working with now...it takes the sheet, copies everything to a row takes that row, moves it to the NCMR Data tab and then clears the data on the new row from the original sheet.
This code technically could work, but what I need to do is make it use the same concept, but instead of creating a new row at the end of the sheet find the original line and replace the data from B to U in whatever row it was originally in.
I know it's possible, I just don't know how.
'Copy Ranges Variable
Dim c As Variant
'Paste Ranges Variable
Dim p As Range
'Setting Sheet
Set wsInt = Sheets("Form")
Set wsNDA = Sheets("Data")
Set p = wsInt.Range("A14")
With wsInt
c = Array(.Range("B11"))
End With
For i = LBound(c) To UBound(c)
p(i + 1).Value = c(i).Value
Next
With wsNDA
Dim Lastrow As Long
Lastrow = .Range("B" & Rows.Count).End(xlUp).Row + 1
wsInt.Rows("14").Copy
With .Rows(Lastrow)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
.Interior.Pattern = xlNone
End With
With .Range("A" & Lastrow)
If Lastrow = 3 Then
.Value = 1
Else
.Value = Val(wsNDA.Range("A" & Lastrow - 1).Value) + 1
End If
.NumberFormat = "0#######"
End With
End With
End Sub
I found this code:
Sub CopyTest()
Dim selrow As Range, rngToCopy As Range
With Worksheets("PD DB")
Set selrow = .Range("B:B").Find(.Range("BA1").Value)
'find the cell containing the value
Set rngToCopy = Union(selrow.Offset(0, 9), selrow.Offset(0, 12))
'use offset to define the ranges to be copied
rngToCopy.Copy Destination:=Worksheets("Edit Sheet").Range("B50")
'copy and paste (without Select)
End With
End Sub
As far as I can tell this will do what I want mostly, but I can't seem to figure out where to break it up to add it where I need to to make it work the way I want it to.
What I can tell is this, it will copy and paste, but I want to make sure it will paste the data into row it finds, and not overwrite the number of said row.
Can someone help make that possible with the two scripts I have here?
Not tested, but should get you started. I added a 3rd sheet (shtMap) to hold the mmapping between the cell addresses on your form and the column numbers on the "Data" sheet. Useful to name your sheets directly in the VB editor: select the sheet and set the name in the property grid.
*EDIT:*If you want to trigger the transfer on selecting a record id from a list in Range AG3 then place this code in the code module for that worksheet:
Private Sub Worksheet_Change(ByVal Target As Range)
Static bProcessing As Boolean
Dim rng As Range
If bProcessing Then Exit Sub
Set rng = Target.Cells(1)
If Not Application.Intersect(rng, Me.Range("AG3")) Is Nothing Then
bProcessing = True
'this is where you call your macro to transfer the record
bProcessing = False
End If
End Sub
You could use something like this for the transfer:
Public Enum XferDirection
ToForm = 1
ToDataSheet = 2
End Enum
Sub FetchRecord()
TransferData XferDirection.ToForm
End Sub
Sub SaveRecord()
TransferData XferDirection.ToDataSheet
End Sub
Sub TransferData(Direction As XferDirection)
Dim rngMap As Range, rw As Range, f As Range, dataCell As Range
Dim formCell As Range, dataCol As Long, dataRow As Long
Dim sId As String
sId = shtForm.Range("AG3").Value
Set f = shtData.Columns(1).Find(sId, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
dataRow = f.Row
Else
'what do you want to do here?
' record doesn't exist on data sheet
MsgBox "Record '" & sId & "' not found on '" & shtForm.Name & "' !"
Exit Sub
End If
Set rngMap = shtMap.Range("A2:B10")
For Each rw In rngMap.Rows
'the cell on the edit form
Set formCell = shtForm.Range(rw.Cells(1).Value)
'column # on datasheet
Set dataCell = shtData.Cells(dataRow, rw.Cells(2).Value)
If Direction = XferDirection.ToDataSheet Then
dataCell.Value = formCell.Value
Else
formCell.Value = dataCell.Value
End If
Next rw
End Sub
Matt, there are two approaches I would take. The first is use find(), which returns a range object, then append ".row" so that you'll be able to modify the row on Sheet2 (wsNDA, I think). You may want to test that find() doesn't return Nothing.
Dim foundRow as Long
Dim foundRng as Range
set foundRng = wsNDA.find(wsInt.Range("B11").Value, ...)
If Not foundRng is Nothing Then
foundRow = foundRng.row
End If
'method without check: foundRow = wsNDA.find(wsInt.Range("B11").Value, ...).Row
The other is to use a Dictionary object. I'm not sure what you'd want for the key, but the item could be the row on the data sheet. When you make the change to what's on the form, check against the key and grab its item (the corresponding row) to determine where you need to replace the values.

Resources