I need to do a find-and-replace on pagesetup leftheader. Caveat is that I need to know the contents of the LeftHeader in order to replace it using Substitute. For example, the LeftHeader could contain:
Sheet 1 - Updated - 1/12/19
Printed on 6/3/19
I would do a find-and-replace on 1/12/19 and 6/3/19 using below example code:
Sub FnR_HF()
Dim sWhat As String, sReplacment As String
Const csTITLE As String = "Find and Replace"
sWhat = InputBox("Replace what", csTITLE)
If Len(sWhat) = 0 Then Exit Sub
sReplacment = InputBox("With what", csTITLE)
With ActiveSheet.PageSetup
' Substitute Header/Footer values
.LeftHeader = Application.WorksheetFunction.Substitute( _
.LeftHeader, sWhat, sReplacment)
End With
End Sub
The above doesn't allow me to retrieve the contents of the LeftHeader. Can anyone help?
Rather than find/replace, why not just rename it?
It will generate a popup box with your existing header showing, and you can type over it with whatever you want the new header to be. Seems easier?
Sub MakeAHeader()
Dim aText As String, WS As Worksheet
Set WS = ActiveSheet
aText = InputBox("What do you want the header to be?", "Make Yo Header", WS.PageSetup.LeftHeader)
WS.PageSetup.LeftHeader = aText
MsgBox "This is your header: " & WS.PageSetup.LeftHeader
End Sub
Try this code
Sub FnR_HF()
Dim sWhat As String, sReplacment As String, sHeader As String
Const csTITLE As String = "Find and Replace"
sHeader = ActiveSheet.PageSetup.LeftHeader
sWhat = InputBox("Replace what", sHeader)
If Len(sWhat) = 0 Then Exit Sub
sReplacment = InputBox("With What", csTITLE)
sHeader = Replace(sHeader, sWhat, sReplacment)
ActiveSheet.PageSetup.LeftHeader = sHeader
End Sub
Related
I have a column in a spreadsheet.
The format of the data in each cell is aa-0001-xx.
I need to examine the whole column to find the highest value of the sequence number. this would be the substring from column4 thru column7.
I can find the sequence number using Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4)
But I need to find the max sequence in the whole column.
I am doing this in VBA.
Any help would be appreciated.
Here is my code so far:
Private Sub CommandButton1_Click()
Dim sQuoteNumber As String
Dim sFileName As String
Dim sPathName As String
Dim checkit As String
'Log the Quote
'First, open the log file and determine the next sequential log number.
sPathName = "C:\Users\Rich\Documents\Bryan\BigProject\"
sFileName = "QuoteLog2016.xlsx"
ControlFile = ActiveWorkbook.Name
Workbooks.Open Filename:=sPathName & sFileName
'Create the new Quote Number
checkit = Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4) ' This is a temp test line
If Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4) = "" Then
sQuoteNumber = "16-0001"
Else
'find the biggest number
'Here I was looking to like pass the mid function to a Max function of some sort.
sQuoteNumber = "16-0002"
End If
MsgBox ("The new Quote Number is: " + sQuoteNumber)
'Save the log entry
Workbooks(sFileName).Close
All of the comments made to your answer would work well for you. It's also true that there's no evidence in your code at having attempted something, however rudimentary, and this is why answers to a rather trivial task are not forthcoming for you. Perhaps, in future, have a go at some kind of solution ( even if it feels more guesswork than anything) and people on this site will be much more supportive of you.
To set you on your way, you could make use of the Split() function which converts a String into a String array, separated by a nominated value - in the case of your quotations, you could use "-" as your separator. This might be easier than your Mid function and will deal with the case of different sized quotations.
The code below will get you started but you'd want some error handling in there to test, for example, that each cell splits appropriately or that any cells aren't blank. I'll leave all of that to you.
Option Explicit
Private mLastQuote As Long
Public Sub Test()
Initialise 'call this routine just once at the start of your project
MsgBox GetNextQuote(16) 'use the GetNextQuote() function to get next number
MsgBox GetNextQuote(16)
MsgBox GetNextQuote(16)
End Sub
Private Function GetNextQuote(prefix As Integer) As String
mLastQuote = mLastQuote + 1
GetNextQuote = CStr(prefix) & "-" & _
Format(mLastQuote, "000#")
End Function
Private Sub Initialise()
Const PATH_NAME As String = "C:\Users\Rich\Documents\Bryan\BigProject\"
Const FILE_NAME As String = "QuoteLog2016.xlsx"
Const QUOTE_COL As String = "B"
Dim wb As Workbook
Dim ws As Worksheet
Dim v As Variant
Dim r As Long
Dim parts() As String
Dim num As Long
Application.ScreenUpdating = False
Set wb = Workbooks.Open(PATH_NAME & FILE_NAME, True, True)
Set ws = wb.Worksheets("Sheet1")
'Read quote values into variant array
With ws
v = .Range(.Cells(2, QUOTE_COL), _
.Cells(.Rows.Count, QUOTE_COL).End(xlUp)) _
.Value2
End With
'Find max quote
For r = 1 To UBound(v, 1)
parts = Split(v(r, 1), "-") 'splits quote into 3 parts
num = CLng(parts(1)) 'index (1) is the middle part
If num > mLastQuote Then mLastQuote = num
Next
wb.Close False
Application.ScreenUpdating = True
End Sub
I'm trying to delete any page that contains a specific text such as the sentence below (strSearch =). But I get a 5904 Error when I try running my macro... Any clue?
Sub DeletePages()
Dim strSearch As String
Dim rgeStart As Range
Set rgeStart = Selection.Range
strSearch = "Report the content of the ""StatusBar"" status bar message to the results."
With ActiveDocument.Range.Find
.Text = strSearch
Do While .Execute
With .Parent
.Select With Selection
.Bookmarks("\Page").Range.Delete
End With
End With
Loop
End With
rgeStart.Select
Application.Browser.Target = wdBrowsePage
End Sub
I get a syntax error on .Select With Selection, and there is no intellisense with this line...it seems that objects are not able to access properties and methods because with statements are embedded in one another.
The following worked for me...I had to delete the last page differently
Sub DeletePages()
'source1 http://stackoverflow.com/questions/13465709/repeating-microsoft-word-vba-until-no-search-results-found
'source2 https://msdn.microsoft.com/en-us/library/bb208876(v=office.12).aspx
Dim strSearch As String
strSearch = "GoodBye"
With Selection.Find
.Forward = True
.Wrap = wdFindStop
.Text = strSearch
.Execute
End With
Do While Selection.Find.Found = True And iCount < 1000
iCount = iCount + 1
Selection.HomeKey Unit:=wdStory
Selection.Find.Execute
If Selection.Find.Found Then
'Get Current page
CurPage = Selection.Information(wdActiveEndAdjustedPageNumber)
'Check if current page is the last page
If CurPage = FindLastPage Then
ActiveDocument.Range(Selection.Start, ActiveDocument.Range.End).Delete
Else
ActiveDocument.Bookmarks("\Page").Range.Delete
End If
End If
Loop
End Sub
Function FindLastPage()
'Source https://support.microsoft.com/en-us/kb/293861
'Iterate each section in the document to retrieve the end page of the
'document and compute the page count in that section. The results are
'displayed in the Immediate window.
Dim oSec As Object
Dim nStartPg As Integer, nEndPg As Integer, nSecPages As Integer
Dim NumSections As Integer
NumSections = ActiveDocument.Sections.Count
nStartPg = 1
For Each oSec In ActiveDocument.Sections
nEndPg = oSec.Range.Information(3) - 1 'wdActiveEndPageNumber=3
'Account for the last page.
If oSec.Index = NumSections Then nEndPg = nEndPg + 1
nSecPages = nEndPg - nStartPg + 1
FindLastPage = nSecPages
Next
End Function
I am trying to fix a simple loop so that the message box won't go away until the user enters an integer.
Here is my code:
Sub PlateMicro()
strName = InputBox(Prompt:="Enter number of wells in plate. The default is 96 (8X12).", _
Title:="PLATE SETUP", Default:="96")
Dim wellCount As Object
Dim numericCheck As Boolean
numericCheck = IsNumeric(wellCount)
If IsNumeric(wellCount) Then
Range("A1").Value = wellCount 'Enter the number of plate wells selected into template.
Else: strName = InputBox(Prompt:="You must enter an integer. Enter number of wells in plate. The default is 96 (8X12)." _
, Title:="PLATE SETUP", Default:=userDefaultChoice)
End If
End Sub
Consider:
Sub intCHECK()
Dim var As Variant
var = "whatever"
While Not IsNumeric(var)
var = Application.InputBox(Prompt:="Enter integer", Type:=2)
Wend
MsgBox "Thanks!"
End Sub
This will allow you to Exit if you touch Cancel
I want to find the text and get the page number of text found in acrobat using VBA, I am able to find the text but not able to get the page number. for that
Sub Main()
Dim acrApp, acrAVDoc
Set acrApp = CreateObject("AcroExch.app")
Set acrAVDoc = CreateObject("AcroExch.AVDoc")
acrApp.Show
If acrAVDoc.Open("FileName", "") Then
Ok = acrAVDoc.FindText("Text to search", 0, 1, 1)
MsgBox (Ok)
End If
Set acrAVDoc = Nothing
Set acrApp = Nothing
End Sub
I am not able to set the object for
Set acrPDDoc = CreateObject("Acrobat.AV_PAGE_VIEW")
I know this is an old question, but it was one of the top search results when I was looking for the same info. I never found anything that truly met my needs so I made something up by combining several different resources.
The function below is acceptably fast, even on very large documents. It searches page by page, not word by word, so it will find multi-word matches and words with dashes (case insensitive). It returns the matches for all pages separated by commas.
Hope this is helpful to someone in the future.
Sub Demo()
Dim SearchResult As String
SearchResult = AdobePdfSearch("my search string", "C:\Demo\Demo.pdf")
MsgBox SearchResult
End Sub
Function AdobePdfSearch(SearchString As String, strFileName As String) As String
'Note: A Reference to the Adobe Library must be set in Tools|References!
'Note! This only works with Acrobat Pro installed on your PC, will not work with Reader
Dim AcroApp As CAcroApp, AcroAVDoc As CAcroAVDoc, AcroPDDoc As CAcroPDDoc
Dim AcroHiliteList As CAcroHiliteList, AcroTextSelect As CAcroPDTextSelect
Dim PageNumber, PageContent, Content, i, j, iNumPages
Dim strResult As String
Set AcroApp = CreateObject("AcroExch.App")
Set AcroAVDoc = CreateObject("AcroExch.AVDoc")
If AcroAVDoc.Open(strFileName, vbNull) <> True Then Exit Function
Set AcroPDDoc = AcroAVDoc.GetPDDoc
iNumPages = AcroPDDoc.GetNumPages
For i = 0 To iNumPages - 1
Set PageNumber = AcroPDDoc.AcquirePage(i)
Set PageContent = CreateObject("AcroExch.HiliteList")
If PageContent.Add(0, 9000) <> True Then Exit Function
Set AcroTextSelect = PageNumber.CreatePageHilite(PageContent)
' The next line is needed to avoid errors with protected PDFs that can't be read
On Error Resume Next
For j = 0 To AcroTextSelect.GetNumText - 1
Content = Content & AcroTextSelect.GetText(j)
Next j
If InStr(1, LCase(Content), LCase(SearchString)) > 0 Then
strResult = IIf(strResult = "", i + 1, strResult & "," & i + 1)
End If
Content = ""
Next i
AdobePdfSearch = strResult
'Uncomment the lines below if you want to close the PDF when done.
'AcroAVDoc.Close True
'AcroApp.Exit
'Set AcroAVDoc = Nothing: Set AcroApp = Nothing
End Function
sub checks each page of pdf, word by word
Sub FindtextandPageNumber()
Dim FindWord 'Word you want to search
Dim acroAppObj As Object
Dim PDFDocObj As Object
Dim myPDFPageHiliteObj As Object
Dim iword As Integer, iTotalWords As Integer
Dim numOfPage As Integer, Nthpage As Integer
Dim word As String, sPath As String
Set acroAppObj = CreateObject("AcroExch.App")
Set PDFDocObj = CreateObject("AcroExch.PDDoc")
Set myPDFPageHiliteObj = CreateObject("AcroExch.HiliteList")
Check3 = myPDFPageHiliteObj.Add(0, 32767)
FindWord = "Hello"
acroAppObj.Show
sPath = "Test.pdf" 'Path of pdf where you want to search
PDFDocObj.Open (sPath)
numOfPage = PDFDocObj.GetNumPages
word = vbNullString
Set PDFJScriptObj = Nothing
For Nthpage = 0 To numOfPage - 1
Set pAcroPDPage = PDFDocObj.AcquirePage(Nthpage)
Set wordHilite = pAcroPDPage.CreateWordHilite(myPDFPageHiliteObj)
Set PDFJScriptObj = PDFDocObj.GetJSObject
iTotalWords = wordHilite.GetNumText
iTotalWords = PDFJScriptObj.getPageNumWords(Nthpage)
''check the each word
For iword = 0 To iTotalWords - 1
word = Trim(CStr(PDFJScriptObj.getPageNthWord(Nthpage, iword)))
If word <> "" Then
If word = FindWord Then
PageNumber = Nthpage
msgbox PageNumber
End If
word = ""
End If
Next iword
Next Nthpage
End Sub
I am making a macro that do a simple replacement in all chart titles. It works very well but suppress all format : italic, bold, ...
Here is the code :
Function trouverItalique(ByRef g As ChartObject)
Dim phrase As String
For i = 0 To Len(g.Chart.ChartTitle.Text)
If InStr(g.Chart.ChartTitle.Characters(i, 1).Font.FontStyle, "Italic") > 0 Then
phrase = phrase & g.Chart.ChartTitle.Characters(i, 1).Text
End If
Next
trouverItalique = phrase
End Function
Private Sub CommandButton1_Click()
Dim char As ChartObject
For Each s In ActiveWorkbook.Worksheets
For Each char In s.ChartObjects
If char.Chart.HasTitle Then
Dim phrase As String
'phrase = trouverItalique(char)
'char.Chart.ChartArea.AutoScaleFont = False
char.Chart.ChartTitle.Characters.Text = replace(char.Chart.ChartTitle.Characters.Text, TextBox1.Text, TextBox2.Text)
Dim index As Integer
'index = InStr(char.Chart.ChartTitle.Characters.Text, phrase)
'char.Chart.ChartTitle.Characters(index, Len(phrase)).Font.Italic = True
End If
Next
Next
End Sub
It works only for some cases and only for to keep the italic, I would like to keep bold and other formats. Do you have an idea to make my code works for any case ? Did I miss a cool mecanism to do the same thing without all of my peregrination ?
Try this:
Sub tester()
ReplaceTitle ActiveSheet.ChartObjects(1).Chart, "ghj", "fffffff"
End Sub
Private Sub ReplaceTitle(cht As Chart, ReplaceWhat As String, ReplaceWith As String)
Dim sTitle As String, pos
If cht.HasTitle Then
pos = InStr(cht.ChartTitle.Characters.Text, ReplaceWhat)
If pos > 0 Then
cht.ChartTitle.Characters(pos, Len(ReplaceWhat)).Text = ReplaceWith
End If
End If
End Sub