In my research, I've encountered two possibilities for inserting a carriage return into a header in a VBA macro, using Chr(10) or Chr(13). I've even seen code posted by Allen Wyatt at excel.tips.com that seems to do exactly what I'm attempting, but where he asserts it works, I have yet to see success.
Here is the basic code I am attempting to execute:
With ActiveSheet.PageSetup
.CenterHeader = "&F" & Chr(10) & "&A"
End With
There is other formatting I'm doing, but it all succeeds. This line only produces the filename in the header ("&F"), but no return and no tab name on the second line. It also doesn't fail; it just continues right through this line.
This macro was originally recorded by me in Excel 2010, which I then augmented with additional automation for page formatting. I'm still running it under Excel 2010, and it has never worked correctly on this particular line. Does anyone have knowledge of what might be transpiring here?
Edit: Here is the full code from the original macro recording and my edits.
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
.LeftHeader = ""
.CenterHeader = "&F" & vbCrLf & "&A"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = "Printed &D"
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Agree with Patrick H. This code works ...
Sub header()
With ActiveSheet.PageSetup
.CenterHeader = "&F" & vbCrLf & "&A"
End With
End Sub
Related
I'm currently having difficulty with a VBScript I'm writing that contains several read and replaces from a text file. The expression I'm using finds the expression and replaces it, but adds three tab spaces afterwords, making the original line below it mess up the formatting. Here's a picture of what I'm talking about:
Here's a pastebin of the before and after, rather than an image:
https://pastebin.com/Uw3H59QK
Here's my RegExp code:
Set fso = CreateObject("Scripting.FileSystemObject")
Dim strPath
strPath = SelectFolder( "" )
If strPath = vbNull Then
WScript.Echo "Script Cancelled - No files have been modified" 'if the user cancels the open folder dialog
Else
WScript.Echo "Selected Folder: """ & strPath & """" 'prompt that tells you the folder you selected
End If
Function SelectFolder( myStartFolder )
Dim objFolder, objItem, objShell
Dim objFolderItems
On Error Resume Next
SelectFolder = vbNull
Set objShell = CreateObject( "Shell.Application" )
Set objFolder = objShell.BrowseForFolder( 0, "Please select the .dat file location folder", 0, myStartFolder)
set objFolderItems = objFolder.Items
If IsObject( objFolder ) Then SelectFolder = objFolder.Self.Path
Set objFolder = Nothing
Set objShell = Nothing
On Error Goto 0
End Function
Set re = New RegExp 'Replacing Position Lines
re.Pattern = "Pos = \((.*)\)"
re.Global = True
re.IgnoreCase = True
For Each f in fso.GetFolder(strPath).Files
If LCase(fso.GetExtensionName(f.Name)) = "txt" Then
text = f.OpenAsTextStream.ReadAll 'reading the text file
f.OpenAsTextStream(2).Write re.Replace(text, """Position"" : mathutils.Vector(($1)),")
count = count + 1
End If
Next
Set reAngles = New RegExp 'Replacing Angles
reAngles.Pattern = "Angles = \((.*)\)"
reAngles.Global = True
reAngles.IgnoreCase = True
For Each f in fso.GetFolder(strPath).files
If LCase(fso.GetExtensionName(f.Name)) = "txt" Then
text = f.OpenAsTextStream.ReadAll
f.OpenAsTextStream(2).Write reAngles.Replace(text, """Angles"" : mathutils.Vector(($1)),")
End If
Next
Set reNames = New RegExp 'Replacing Names
reNames.Pattern = "Name = (.*)"
reNames.Global = True
'reNames.Multiline = True
reNames.IgnoreCase = True
For Each f in fso.GetFolder(strPath).files
If LCase(fso.GetExtensionName(f.Name)) = "txt" Then
text = f.OpenAsTextStream.ReadAll
f.OpenAsTextStream(2).Write reNames.Replace(text, """Name"" : ""$1"",")
End If
Next
My best guess is that the wildcard is grabbing more info than needed...but I'm unsure how to fix that. I used a lot of these expressions in Notepad++ so I was hoping to translate them to a VBS easily!
I am looking to clean up a .csv file for a database import. I am using the following vbs function and would like to incorporate '' to vbNull. I find it hard to understand RegEx. Can this even be done?
Function removeEmbeddedCommasInCSVTextField (strtoclean)
Dim objRegExp, outputStr
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = """[^""]*,[^""]*"""
Set objMatch = objRegExp.Execute( strtoclean )
corrected_row = strtoclean
For Each myMatch in objMatch
matched_value = myMatch.Value ' retrieves text column with embedded commas
cleaned_value = replace(matched_value, ",","") ' removes embeddes commans from column
corrected_row = replace(corrected_row, matched_value, cleaned_value) 'take row and replaced bad value with good value (no commas)
Next
removeEmbeddedCommasInCSVTextField = corrected_row
End Function
MAIN:
Set MyFile = fso.CreateTextFile(strShareDirectory & "fixed.txt", True)
Set f = fso.OpenTextFile(strShareDirectory & filename)
Do Until f.AtEndOfStream
before_clean = f.ReadLine
after_clean = removeEmbeddedCommasInCSVTextField(before_clean)
MyFile.WriteLine(after_clean)
'WScript.Echo after_clean
Loop
f.Close
MyFile.Close
I want to create a shortcut in libreoffice to replace spaces by underscore.
I recorded a macro
I performed a simple find & replace.
But everytime I try to run the macro libreoffice quit ;(
this is the code
REM ***** BASIC *****
sub replacespaces
rem ----------------------------------------------------------------------
rem define variables
dim document as object
dim dispatcher as object
rem ----------------------------------------------------------------------
rem get access to the document
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
rem ----------------------------------------------------------------------
dim args1(17) as new com.sun.star.beans.PropertyValue
args1(0).Name = "SearchItem.StyleFamily"
args1(0).Value = 2
args1(1).Name = "SearchItem.CellType"
args1(1).Value = 0
args1(2).Name = "SearchItem.RowDirection"
args1(2).Value = true
args1(3).Name = "SearchItem.AllTables"
args1(3).Value = false
args1(4).Name = "SearchItem.Backward"
args1(4).Value = false
args1(5).Name = "SearchItem.Pattern"
args1(5).Value = false
args1(6).Name = "SearchItem.Content"
args1(6).Value = false
args1(7).Name = "SearchItem.AsianOptions"
args1(7).Value = false
args1(8).Name = "SearchItem.AlgorithmType"
args1(8).Value = 1
args1(9).Name = "SearchItem.SearchFlags"
args1(9).Value = 71680
args1(10).Name = "SearchItem.SearchString"
args1(10).Value = " "
args1(11).Name = "SearchItem.ReplaceString"
args1(11).Value = "_"
args1(12).Name = "SearchItem.Locale"
args1(12).Value = 255
args1(13).Name = "SearchItem.ChangedChars"
args1(13).Value = 2
args1(14).Name = "SearchItem.DeletedChars"
args1(14).Value = 2
args1(15).Name = "SearchItem.InsertedChars"
args1(15).Value = 2
args1(16).Name = "SearchItem.TransliterateFlags"
args1(16).Value = 1280
args1(17).Name = "SearchItem.Command"
args1(17).Value = 3
dispatcher.executeDispatch(document, ".uno:ExecuteSearch", "", 0, args1())
rem ----------------------------------------------------------------------
dispatcher.executeDispatch(document, ".uno:SearchResultsDialog", "", 0, Array())
end sub
Can someone tell me what's wrong ?
The macro recorder of openoffice and libreoffice is not really so much helpful as the one of Microsoft Office. I would suggest not to use it. Instead recording a macro, use a tool like XRAY ( https://wiki.documentfoundation.org/Macros) for examining the objects you have found using the methods of the API. At first examine thisComponent. Doing so, with Calc, you will find a model which has multiple models of sheets which each implements an interface XReplaceable (http://api.libreoffice.org/docs/idl/ref/interfacecom_1_1sun_1_1star_1_1util_1_1XReplaceable.html).
Example:
Sub findAndReplace()
oModel = thisComponent ' at first examine thisComponent
' xray oModel
oSpreadSheet = oModel.getCurrentController().getActiveSheet()
' oSpreadSheet = oModel.getSheets().getByIndex(0)
' xray oSpreadSheet
xReplaceDescr = oSpreadSheet.createReplaceDescriptor()
' xray xReplaceDescr
xReplaceDescr.SearchString = " "
xReplaceDescr.ReplaceString = "_"
lFound = oSpreadSheet.replaceAll(xReplaceDescr)
' xray lFound
MsgBox lFound & " replacements done."
End Sub
This program finds certain words in a MS Word document using the RegExp method. Once each match is found, the program is supposed to find the page of each match and create a string that can be output to show all pages where that keyword match was found. The way it's written now, for some reason it's outputting a "1" for each page no matter what page it's found on. For example, if the word "Mouse" was found on page 1, 5, and 22, it would output 1, 1, 1,.
For Each Match In RegExp.Execute(oWord.ActiveDocument.Range.Text)
myKeyWords(numKeywords) = Match.Value
PageNumbers(numKeywords) = ""
With myWordDoc.ActiveDocument.Range.Find
.ClearFormatting()
.Text = Match.value
.Wrap = False
.Forward = True
Do While .Execute = True
If PageNumbers(numKeywords) = "" Then
PageNumbers(numKeywords) = oWord.Selection.Information(Word.WdInformation.wdActiveEndAdjustedPageNumber)
Else
PageNumbers(numKeywords) = PageNumbers(numKeywords) & ", " & oWord.Selection.Information(Word.WdInformation.wdActiveEndAdjustedPageNumber)
End If
Loop
End With
The numKeywords isn't incrementing. I've written it out without the
For Each Match In RegExp.Execute(oWord.ActiveDocument.Range.Text)
Here it is, be aware that if you take this function outside of the regexp method that you'll need to change the .Text = myKeywords(x) and remove the .range before find.
PageNumbers(numKeywords) = ""
For x = LBound(myKeywords) To UBound(myKeywords)
PageNumbers(x) = ""
With myWordDoc.ActiveDocument.Find
.ClearFormatting()
.Text = myKeywords(x)
.Wrap = False
.Forward = True
Do While .Execute = True
If PageNumbers(numKeywords) = "" Then
PageNumbers(numKeywords) = oWord.Selection.Information(Word.WdInformation.wdActiveEndAdjustedPageNumber)
Else
PageNumbers(numKeywords) = PageNumbers(numKeywords) & ", " & oWord.Selection.Information(Word.WdInformation.wdActiveEndAdjustedPageNumber)
End If
Loop
End With
strDeger1 = """ >"
strDeger2 = "</a>"
strBaslikBul = VeriBul(strDeger1, strDeger2)
Response.Write strBaslikBul
Response.Write "<hr>"
Set RegEx = New RegExp
RegEx.IgnoreCase = True
RegEx.Global = True
RegEx.Pattern = "(" & BaslangicDegeri & ")(.+?)(" & BitisDegeri & ")"
Set Sonuc = RegEx.Execute(Trim(tr(Mid(HTTPObj2.GetURL,29600,254000))))
For Each i In Sonuc
VeriBul = i.SubMatches(1)
Next
If IsEmpty(VeriBul) Then VeriBul = "Sonuc Yok"
Set RegEx = Nothing
Set Sonuc = Nothing
Set objXmlHttp = Nothing
End Function
I have like this code, I'm trying to make listing all for records. But just one of record viewing.
How I can fix this?
Thanks.
Also need to concat for each match. Modify line
VeriBul = i.SubMatches(1) with VeriBul = VeriBul & i.SubMatches(1)