I am trying to import some word documents as footer with the following code. Unfortunately, the selection.insertfile function inserts additionally a new line at the end of the footer. Is it possible to remove it? I've tried many things, without a result.
Public Sub AutoOpen()
'Fußzeile aktualisieren
Call UpdateFooter
End Sub
'Fußzeile für alle Seiten editieren
Sub UpdateFooter()
Application.ScreenUpdating = False
Dim oDoc As Word.Document, oSec As Word.section, rng As Word.Range
Set oDoc = ActiveDocument
For Each oSec In oDoc.Sections
Set rng = oSec.Footers(Word.WdHeaderFooterIndex.wdHeaderFooterFirstPage).Range
AddFooterToRange rng
'oSec.Footers(Word.WdHeaderFooterIndex.wdHeaderFooterFirstPage).Range.Font.Size = 5
Set rng = oSec.Footers(Word.WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
AddFooterToRange rng
'oSec.Footers(Word.WdHeaderFooterIndex.wdHeaderFooterPrimary).Range.Font.Size = 5
Set rng = oSec.Footers(Word.WdHeaderFooterIndex.wdHeaderFooterEvenPages).Range
AddFooterToRange rng
'oSec.Footers(Word.WdHeaderFooterIndex.wdHeaderFooterEvenPages).Range.Font.Size = 5
Next oSec
Application.ScreenUpdating = True
End Sub
'Fußzeilendatei einfügen
Private Sub AddFooterToRange(rng As Word.Range)
With rng
.InsertFile "...fusszeile.docx"
End With
End Sub
Thanks in advance.
You just need to delete the last paragraph in the footer.
Private Sub AddFooterToRange(rng As Word.Range)
With rng
.InsertFile "...fusszeile.docx"
.Paragraphs.Last.Range.Delete
End With
End Sub
Related
I am trying to prompt every paragraph after every image in an active document. For some reason, the prompt pops up empty.
Sub Example1()
Dim intCount As Integer
Dim i As Integer
Dim strCaption As String
'loop through inline shapes
For i = 1 To ActiveDocument.InlineShapes.Count
'check if the current shape is an picture
If ActiveDocument.InlineShapes.Item(i).Type = wdInlineShapePicture Then
strCaption = Selection.Paragraphs(1).Range
MsgBox strCaption
End If
Next i
End Sub
This code might work, depending upon how your InlineShapes are positioned. The code presumes that each picture is in its own paragraph and then picks out the next.
Sub Example1()
Dim i As Integer
Dim strCaption As String
Dim Rng As Range
With ActiveDocument.InlineShapes
'loop through inline shapes
For i = 1 To .Count
With .Item(i)
'check if the current shape is a picture
If .Type = wdInlineShapePicture Then
Set Rng = .Range.Paragraphs(1).Range
With Rng
Do
.Collapse wdCollapseEnd
.MoveEnd wdParagraph
Loop While Len(Trim(.Text)) = 1 And _
.End < .Document.Content.End
strCaption = Rng.Text
End With
MsgBox strCaption
End If
End With
Next i
End With
End Sub
If the text you're after is in the same paragraph as the inlineshape you could use code like:
Sub Demo()
Dim iSHp As InlineShape, Rng As Range
For Each iSHp In ActiveDocument.InlineShapes
Set Rng = iSHp.Range.Paragraphs(1).Range
With Rng
.Start = iSHp.Range.End
MsgBox .Text
End With
Next
End Sub
If the text you're after is in the next paragraph after the inlineshape you could use code like:
Sub Demo()
Dim iSHp As InlineShape, Rng As Range
For Each iSHp In ActiveDocument.InlineShapes
Set Rng = iSHp.Range.Paragraphs(1).Range
With Rng
.Collapse wdCollapseEnd
.MoveEnd wdParagraph, 1
MsgBox .Text
End With
Next
End Sub
I have a seemingly simple goal to turn the content of column B into comments of column A.
I have tried using the following code from #Dy.Lee mentioned here, but unfortunately it gives me a Run-time error '1004' Application-defined or object-defined error...
Sub Komentari()
Dim rngDB As Range, rngComent As Range
Dim rng As Range
Dim cm As Comment, i As Integer
Set rngComent = Range("A1:A50")
Set rngDB = Range("B1:B50")
For Each rng In rngComent
i = i + 1
If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If
Set cm = rng.AddComment
With cm
.Visible = False
.Text Text:=rngDB(i).value
End With
Next rng
End Sub
Can somebody, please, spot the mistake or suggest a better solution for this?
I'd go this way (explanations in comments):
Public Sub Komentari()
Dim rng As Range
With Range("A1:A50") ' reference comments range
.ClearComments ' clear its comments
For Each rng In .Offset(, 1).SpecialCells(xlCellTypeConstants) ' loop through refrenced range adjacent not empty cells
With rng.Offset(, -1).AddComment ' add comment to current rng corresponding comment range cell
.Visible = False
.Text rng.Value2
End With
Next
End With
End Sub
Sub Komentari()
Dim rngDB As Range, rngComent As Range
Dim rng As Range
Dim cm As Comment, i As Integer
Set rngComent = Range("A1:A50")
For Each rng In rngComent
i = i + 1
If Not rng.Range("B1").Comment Is Nothing Then
rng.Range("B1").Comment.Delete
End If
rng.Range("B1").AddComment (rng.Text)
Next rng
End Sub
Something like the following where you can use Offset to get the adjacent range, you drop the = when adding the text value to the comment, test that there is actually a value present first as well, and ensure you state the sheet to avoid implicit Activesheet reference.
Option Explicit
Public Sub Komentari()
Dim rngComent As Range
Dim rng As Range, cm As Comment
With ThisWorkbook.Worksheets("Sheet1")
Set rngComent = .Range("A1:A50")
For Each rng In rngComent
If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If
Set cm = rng.AddComment
With cm
.Visible = False
If rng.Offset(, 1) <> vbNullString Then .Text rng.Offset(0, 1).Value
End With
Next
End With
End Sub
Rather than add blank comments you could also flip this round to:
Option Explicit
Public Sub Komentari()
Dim rngComent As Range
Dim rng As Range, cm As Comment
With ThisWorkbook.Worksheets("Sheet1")
Set rngComent = .Range("A1:A50")
For Each rng In rngComent
If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If
If rng.Offset(, 1) <> vbNullString Then
Set cm = rng.AddComment
With cm
.Visible = False
.Text rng.Offset(0, 1).Value
End With
End If
Next
End With
End Sub
I wrote the following macro to scan through a PPT document and find/replace a range of words on a referenced excel sheet. This works more or less exactly how I'd like it to. I'm now attempting to set this up for use with Word documents as well, but am having some trouble with the "Word" syntax as it differs a bit. Can anyone help me get started here?
Maybe there's a better way to do this - I wrote it in this manner because it allows any user to open the Excel document, click a button, pull up their document and have the macro do its work.
Sub QE_US()
'VARIABLES
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.presentation
Dim fnd As Variant
Dim rplc As Variant
Dim FindArray As Variant
Dim ReplaceArray As Variant
Dim TxtRng As PowerPoint.TextRange
Dim TmpRng As PowerPoint.TextRange
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim objPPT As Object
'PROMPT USER TO OPEN POWERPOINT DOC
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
AppActivate Application.Caption
strFileToOpen = Application.GetOpenFilename _
(Title:="Please Choose PowerPoint for QE - US Conversion")
If strFileToOpen = False Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
GoTo Ending
End If
objPPT.Presentations.Open Filename:=strFileToOpen
'PULLING ARRAY FROM EXCEL
FindArray = Application.Transpose(ThisWorkbook.Worksheets("Conversion").Range("C3:C64"))
ReplaceArray = Application.Transpose(ThisWorkbook.Worksheets("Conversion").Range("B3:B64"))
'LOOP THROUGH EACH SLIDE
For Each sld In objPPT.ActivePresentation.Slides
objPPT.Activate
objPPT.ActiveWindow.View.GotoSlide sld.SlideIndex
For y = LBound(FindArray) To UBound(FindArray)
For Each shp In sld.Shapes
fnd = FindArray(y)
rplc = ReplaceArray(y)
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
Set TxtRng = shp.TextFrame.TextRange.Find(fnd, 0, True, WholeWords:=msoFalse)
If TxtRng Is Nothing Then GoTo NextTxtRng
TxtRng.Select
AppActivate Application.Caption
If MsgBox("Replace " & fnd & " with " & rplc & "?", vbYesNo + vbSystemModal) = vbYes _
Then Set TmpRng = TxtRng.Replace(FindWhat:=fnd, _
ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=True)
End If
End If
'REPLACE OTHER INSTANCES
Do While Not TmpRng Is Nothing
Set TmpRng = TxtRng.Replace(FindWhat:=fnd, _
ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=False)
Loop
'IF TEXT RANGE IS NOTHING (NO VALUE FOUND)
NextTxtRng:
Next shp
Next y
Next sld
AppActivate Application.Caption
MsgBox "QE replaced with US"
'IF NO POWERPOINT SELECTED
Ending:
End Sub
I imagine it can be simplified quite a bit as it's no longer looking through slides, shapes, etc and can just scan the entire document?
Using http://word.mvps.org/faqs/customization/ReplaceAnywhere.htm as a starting point:
Sub ReplaceInWord()
Dim wdApp As New Word.Application, wdDoc As Word.Document, c As Range
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open("C:\Users\twilliams\Desktop\test.docx")
For Each c In ActiveSheet.Range("C3:C64")
If c.Value <> "" Then
FindReplaceAnywhere wdDoc, c.Value, c.Offset(0, -1).Value
End If
Next c
wdDoc.Close True
End Sub
Public Sub FindReplaceAnywhere(doc As Word.Document, pFindTxt As String, pReplaceTxt As String)
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape
'Fix the skipped blank Header/Footer problem
lngJunk = doc.Sections(1).Headers(1).Range.StoryType
'Iterate through all story types in the current document
For Each rngStory In doc.StoryRanges
'Iterate through all linked stories
Do
SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt
On Error Resume Next
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
SearchAndReplaceInStory oShp.TextFrame.TextRange, _
pFindTxt, pReplaceTxt
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, _
ByVal strSearch As String, ByVal strReplace As String)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub
Thanks for pointing me in the right direction. Below is the resulting working code.
Sub US_QE_Word()
'VARIABLES
Dim rngXL As Range
Dim x As Range
Dim strFind As String
Dim strReplace As String
Dim rngStory As Object
Dim lngJunk As Long
Dim objWord As Object
'PROMPT USER TO OPEN DOC
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
AppActivate Application.Caption
strFileToOpen = Application.GetOpenFilename _
(Title:="Please Choose File for US - QE Conversion")
If strFileToOpen = False Then
MsgBox "No file selected."
GoTo Ending
End If
objWord.Documents.Open Filename:=strFileToOpen
'FIND/REPLACE
objWord.ActiveDocument.TrackRevisions = True
Set rngXL = ThisWorkbook.Worksheets("List").Range("B3:B80")
For Each rngStory In objWord.ActiveDocument.StoryRanges
For Each x In rngXL
strFind = x.Value
strReplace = x.Offset(0, 1).Value
With rngStory.Find
.Text = strFind
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next
Next
AppActivate Application.Caption
MsgBox ("US replaced with QE. Please review changes.")
'IF NO FILE SELECTED
Ending:
End Sub
I have a procedure which updates all fields in a document.
However I would like to skip the wdFieldDocVariable, the item index should be Type.
Public Sub MyApplicationUpdate()
hdWriteInfoLog ("BEGIN MACRO: MyApplicationUpdate")
Dim oTOC As TableOfContents
Dim oField As Field
' Update Fields in all document StoryRanges
Dim oStory As Range
For Each oStory In ActiveDocument.StoryRanges
oStory.Fields.Update
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
oStory.Fields.Update
Wend
End If
Next oStory
Set oStory = Nothing
' Update all TablesOfContents
For Each oTOC In ActiveDocument.TablesOfContents
oTOC.Update
Next oTOC
hdWriteInfoLog ("END MACRO: MyApplicationUpdate")
End Sub
I think, I have found the answer, I believe there is a more efficient way of doing this, but at least it works...
' Test procedure
Public Sub MyApplicationUpdate()
hdWriteInfoLog ("BEGIN MACRO: MyApplicationUpdate")
Dim oTOC As TableOfContents
Dim oField As Field
Dim oField2 As Field
' Update Fields in all document StoryRanges
Dim oStory As Range
For Each oStory In ActiveDocument.StoryRanges
For Each oField2 In oStory.Fields
If Not oField2.Type = wdFieldDocVariable Then
oField2.Update
End If
Next oField2
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
' oStory.Fields.Update
For Each oField2 In oStory.Fields
If Not oField2.Type = wdFieldDocVariable Then
oField2.Update
End If
Next oField2
Wend
End If
Next oStory
Set oStory = Nothing
' Update all TablesOfContents
For Each oTOC In ActiveDocument.TablesOfContents
oTOC.Update
Next oTOC
hdWriteInfoLog ("END MACRO: MyApplicationUpdate")
End Sub
I have the following function using Excel 2010:
Private Function MakeAllSheetsValuesOnly(targetBookName As String)
If Excel.ActiveWorkbook.Name = Excel.ThisWorkbook.Name Then
Else
Excel.Workbooks(targetBookName).Activate
Dim mySheet
For Each mySheet In Excel.ActiveWorkbook.Sheets
With mySheet
With .Cells
.Copy
.PasteSpecial Excel.xlPasteValues
End With
.Select
.Range("A1").Select
End With
Excel.ActiveWindow.SmallScroll Down:=-200
Excel.Application.CutCopyMode = False
Next mySheet
End If
End Function 'MakeAllSheetsValuesOnly
It works but I'd rather not rely on the clipboard is there an alternative way to make all sheets values only?
Just found an alternative logic I've been using in another program which is relevent to this topic:
Dim rSource As Range
Dim rDest As Range
Set rSource = .Range("C5:BG" & .Range("B4").Value + 4)
Set rDest = mySummaryBook.Sheets("Data_Measures").Cells(Rows.Count, 4).End(xlUp)(2, 1)
With rSource
Set rDest = rDest.Resize(.Rows.Count, .Columns.Count)
End With
rDest.Value = rSource.Value
Set rSource = Nothing
Set rDest = Nothing
Maybe something like this:
With mySheet.UsedRange
.Value = .Value
End With
You don't need a function for this.
Tim has already given you a great method. Here is another way...
Sub Sample()
MakeAllSheetsValuesOnly "Book2"
End Sub
Private Sub MakeAllSheetsValuesOnly(targetBookName As String)
Dim mySheet As Worksheet
Dim formulaCell As Range
Dim aCell As Range
Application.ScreenUpdating = False
For Each mySheet In Workbooks(targetBookName).Sheets
On Error Resume Next
Set formulaCell = mySheet.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not formulaCell Is Nothing Then
For Each aCell In formulaCell
aCell.Value = aCell.Value
Next
End If
Next mySheet
Application.ScreenUpdating = True
End Sub
Building on Tim's answer above, which seems to be the most efficient way to do it, you could clean up your code to make it a little faster, less resource intensive. See below. Not huge changes, but will help with processing none-the-less. First don't need Function. Sub will do. No need to select and activate so many things:
Private Sub MakeAllSheetsValuesOnly(targetBookName As String)
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Dim wkb As Workbook
Set wkb = Workbooks(targetBookName)
With wkb
Dim mySheet As Worksheet
For Each mySheet In wkb.Worksheets
mySheet.UsedRange.Value = mySheet.UsedRange.Value
Next mySheet
End With
End If
End Sub 'MakeAllSheetsValuesOnly