I have an issue with one of my VBA Word codes which extract every first sentences of every paragraphs which have more than 200 characters in Excel. My problem is that the code works only on one of my two computers, even though they both have the same Office version. Any idea why? Any idea on how to get the exact same result with another code? Thanks!
Sub aHeadlines()
On Error Resume Next
'Word objects
Dim p As Object
Dim s As String
Dim xl
Dim wb, ws, xlr
Set xl = CreateObject("Excel.Application")
xl.Visible = True
Set wb = xl.Workbooks.Add
Set ws = wb.Worksheets(1)
i = 1
For Each p In ActiveDocument.Paragraphs
If Len(p) > 200 Then
Set xlr = ws.Range("a" & i)
p.Range.Sentences(1).copy
xlr.PasteSpecial 3
i = i + 1
End If
Next
End Sub
Related
Hello Stackoverflow community,
I wish to remove unused masterslides from multiples powerpoint presentation.
The list of files is in an excel file.
I wrote a macro that opens each powerpoint files.
I found a macro that used within powerpoint VBA removes unused masterslide but doesn't work when I include it in my Excel macro...
Also I don't manage to save and close each pwp files.
Macro that loops through files :
Dim myPresentation As Object
Dim PowerPointApp As Object
Set myPresentation = CreateObject("Powerpoint.application")
'Find last row of path files list
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
'Looping through files
For i = 1 To lastRow
'Defines pwp file to open
DestinationPPT = Cells(i, "A")
'opens pwp file
myPresentation.presentations.Open DestinationPPT
myPresentation.Visible = True
'Then I would like to : remove unused master slide, save, close
Next i
End Sub
Macro that works when used directly in pwp :
Sub SlideMasterCleanup()
Dim k As Integer
Dim n As Integer
Dim oPres As Presentation
Set oPres = ActivePresentation
On Error Resume Next
With oPres
For k = 1 To .Designs.Count
For n = .Designs(k).SlideMaster.CustomLayouts.Count To 1 Step -1
.Designs(k).SlideMaster.CustomLayouts(n).Delete
Next
Next k
End With
End Sub
What could I do in order to :
succeeding in removing masterslide in my Excel macro
Save and close each pwp before going to the next
Thanks a lot !!
Here's a first shot at revising your code. Give it a try; if it works, great. If not, let us know what went wrong, and on what line of code. Use this ONLY on a copy of your presentation(s). I don't see where you've coded any way of determining whether a layout is used or not.
Option Explicit
Sub Main()
Dim myPresentation As Object
Dim PowerPointApp As Object
Set PowerPointApp = CreateObject("Powerpoint.application")
'Find last row of path files list
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
'Looping through files
For i = 1 To LastRow
'Defines pwp file to open
DestinationPPT = Cells(i, "A")
'opens pwp file
Set myPresentation = PowerPointApp.Presentations.Open(DestinationPPT)
myPresentation.Visible = True
'Then I would like to : remove unused master slide, save, close
Call SlideMasterCleanup(myPresentation)
Next i
End Sub
Sub SlideMasterCleanup(oPres As Presentation)
Dim k As Integer
Dim n As Integer
On Error Resume Next
With oPres
For k = 1 To .Designs.Count
For n = .Designs(k).SlideMaster.CustomLayouts.Count To 1 Step -1
.Designs(k).SlideMaster.CustomLayouts(n).Delete
Next
Next k
End With
oPres.Save
oPres.Close
End Sub
I am new to VBA and macros.
I got the repeated task of copy data from Excel and paste it in a particular location in the word document.
For example, my excel sheet has the data like this:
Col1
Col2
ID_1
I'm_One
ID_2
I'm_Two
ID_3
I'm_Three
Now i'm looking for a Word macro
Get text in Word table with cell position 3
Find the same text in Excel Col1
Get the value of Col2 from Excel
Paste the value of Col2 in word table with cell position 10
Repeat the same process for another table in Word document
[Update]
I have tried with multiple code snippets by google search but unable to construct the working macro.
Sub pull_from_Excel2()
'ref: https://www.macworld.com/article/211753/excelwordvisualbasic.html
Dim Month As String
ID_Range = "A2:A6" 'Select this as range like "A2:A16"
Offset_to_fetch = 1 'Select this to fetch comments etc. value starts with
Set xlSheet = GetObject("D:\Excel.xlsx")
'Snippets:
'Debug.Print VarType(xlSheet.Worksheets("Sheet1").Range("A3:A5").Value)
'8204
Dim Cell As Range, rng As Range
Debug.Print VarType(xlSheet.Worksheets("Sheet1").Range(ID_Range).Value2)
Set rng = xlSheet.Worksheets(1).Range(ID_Range)
For Each Cell In rng
Debug.Print Cell.Text
Next Cell
End Sub
I used this url to construct my skeleton code: https://www.macworld.com/article/211753/excelwordvisualbasic.html
When i try to get the values from the range of cells in excel, i got the following error for the code.
Set rng = xlSheet.Worksheets(1).Range(ID_Range).Value2
The above line gives "Object required" error when running.
Set rng = xlSheet.Worksheets(1).Range(ID_Range)
The above line gives "Type Mismatch" error when running.
Notes: For this error, I tried to use for each loop as this is array but the error is showing before executing the for loop.
Kindly assist.
I recommend to use Option Explicit and declare all your varibales properly. This way it is less likely that you end up with unseen errors.
To activate it for all new codes that you add in the future, you can activate it directly in Excel and Word. This is a good practice and will protect you from doing it wrong by notifying you of not declared variables:
In the VBA editor go to Tools › Options › Require Variable Declaration.
This will add Option Explicit to new modules only. In existing modules Option Explicit needs to be added manually as first line.
Further I highly recommend to name your variables according what they contain because otherwise it gets very confusing. You named your variable xlSheet but you load a workbook into it and not a worksheet.
The next issue is that your code is in Word and if you declare rng As Range then this is of type Word.Range and not Excel.Range and those are diffetent types so that is why you get a "Type Mismatch" error.
To solve this you either go in Word VBA to Extras › Refereces … and set a reference to the Excel library so you can declare your variable Dim xlRng As Excel.Range or if you don't set a reference you declare it as Object or Variant like in below example:
' This code is in Word!
Option Explicit
Public Sub pull_from_Excel2()
'declare constants
Const ID_Range As Sting = "A2:A6" 'Select this as range like "A2:A16"
Const Offset_to_fetch As Long = 1 'Select this to fetch comments etc. value starts with
Dim xlWorkbook As Object
Set xlWorkbook = GetObject("D:\Excel.xlsx") 'This expects the Excel to be already open! If not open you need to use CreateObject("Excel.Application")
Dim xlRng As Object
Set xlRng = xlWorkbook.Worksheets(1).Range(ID_Range)
Dim xlCell As Object
For Each xlCell In xlRng
Debug.Print xlCell.Text
Next xlCell
End Sub
Note if your workbook Set xlWorkbook = GetObject("D:\Excel.xlsx") is not open in Excel you need to use CreateObject("Excel.Application") and open it.
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Dim xlWorkbook As Object
Set xlWorkbook = xlApp.Workbooks.Open(FileName:="D:\Excel.xlsx") 'will open the workbook
xlApp.Visible = True 'make it false to open Excel invisible in the background
'your code here …
'in the end close workbook and Excel (espaciall if you had it invisible!)
xlWorkbook.Close SaveChanges:=False
xlApp.Quit 'close Excel
Option Explicit
Sub UpdateTables()
Const XLSX = "D:\Excel.xlsx"
Dim xlApp, wb, ws
Dim rngSearch, rngFound
Dim iLastRow As Long, n As Integer
' open spreadsheet
'Set xlApp = New Excel.Application
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set wb = xlApp.Workbooks.Open(XLSX, 1, 1)
Set ws = wb.Sheets(1)
iLastRow = ws.Cells(ws.Rows.Count, "A").End(-4162).Row 'xlUp
Set rngSearch = ws.Range("A2:A" & iLastRow)
' update tables
Dim doc As Document, tbl As Table, s As String
Set doc = ThisDocument
For Each tbl In doc.Tables
s = tbl.Cell(1, 1).Range.Text
s = Left(s, Len(s) - 2)
Set rngFound = rngSearch.Find(s, LookIn:=-4163, LookAt:=1) ' xlValues, xlWhole
If rngFound Is Nothing Then
MsgBox "'" & s & "' not found in table " & tbl.Title, vbExclamation
Else
tbl.Range.Cells(3).Range.Text = rngFound.Offset(0, 1)
n = n + 1
End If
Next
wb.Close False
xlApp.Quit
MsgBox n & " tables updated", vbInformation
End Sub
I am trying to retrieve the links in which a PowerPoint is connected to using VBA in Excel. I receive two different errors from the two different approaches in which I will attach below, both stemming from calling the Slide and Shape objects of PowerPoint. The first macro results in an "Object required" error starting with the first line of the For Loop.
Sub Macro1()
'Opening up the PowerPoint to retrieve the links
Dim PPTName As String
Dim PPTApp As Object
PPTName = Sheets("Sheet1").Range("G2").Value
Set PPTApp = CreateObject("PowerPoint.Application")
PPTApp.Presentations.Open PPTName
Dim i As Integer
Dim j As Long
Dim k As Long
i = 10
For j = 1 To PPT.ActivePresentation.Slides.Count
For k = 1 To PPT.ActivePresentation.Slides(i).Shapes.Count
If PPTShape.Type = msoLinkedPicture Or PPTShape.Type = msoLinkedOLEObject Then
Sheets("Sheet1").Range("G" & CStr(i)) = PPTShape.LinkFormat.SourceFullName
i = i + 1
End If
k = k + 1
Next k
j = j + 1
Next j
End Sub
The second macro results in a "Compile error" starting with the "Set PPTSlides = CreateObject("PowerPoint.Slides")."
Sub Macro2()
Dim PPTName As String
Dim PPTApp As Object
PPTName = Sheets("Sheet1").Range("G2").Value
Set PPTApp = CreateObject("PowerPoint.Application")
PPTApp.Presentations.Open PPTName
Dim PPTSlides As Object
Dim PPTShapes As Object
Set PPTSlides = CreateObject("PowerPoint.Slides")
Set PPTShapes = CreateObject("PowerPoint.Shapes")
For Each PPTSlides In PPT.ActivePresentation.Slides
For Each PPTShapes In PPT.ActivePresentation.Shapes
If PPTShape.Type = msoLinkedPicture Or PPTShape.Type = msoLinkedOLEObject Then
Sheets("Sheet1").Range("G" & CStr(i)) = PPTShape.LinkFormat.SourceFullName
i = i + 1
End If
Next PPTShapes
Next PPTSlides
End Sub
I have not used VBA in Excel to work with PowerPoint before, so this is a new learning curve for me. Because of these errors, I have not been able to check my For Loop for errors as well. Any help is appreciated on these issues. Thanks in advance!
Fortunately, that is only a minor issue: A wrong index is used:
i = 10
For j = 1 To PPT.ActivePresentation.Slides.Count
For k = 1 To PPT.ActivePresentation.Slides(i).Shapes.Count
If you look closely, then you need to use j instead of i in the last row.
And for the second code listing, there you can just omit the lines
Set PPTSlides = CreateObject("PowerPoint.Slides")
Set PPTShapes = CreateObject("PowerPoint.Shapes")
Because down below the first variable will be set from ActivePresentation.Slides.
As you are using the for each loop it also make sense to rename these two variables from plural to singular, i.e. PPTSlide instead of PPTSlides.
Please note as well that For Each PPTShapes In PPT.ActivePresentation.Shapes does not work. You need to get the Shapes from For Each PPTShape in PPTSlide.Shapes.
All the best
I've got a manual for a machine that i need to replace a large amount of part numbers with updated ones (17624 numbers). Ive got an excel doc that ive combiled with row A with old numbers and row B with the new numbers. The manual is in word (2016). Ive tried some code that i found but im unable to get it to work. Ive created a smaller excel doc with only a small list of numbers for testing reasons.
Sub findandreplace()
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim i As Integer, j As Integer
Dim lastRow As Integer
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Open("C:\Users\lforget\Downloads\process_batch_folder_addin\list.xlsx")
Set xlWS = xlWB.Worksheets("Sheet1") 'Replace String with your Worksheet Name
lastRow = 1
For i = 1 To ThisDocument.Words.Count - 1 Step 1
For j = 1 To lastRow Step 1
ThisDocument.Words(i) = Replace(ThisDocument.Words(i), xlWS.Cells(j, 1).Value, xlWS.Cells(j, 2).Value)
Next j
Next i
Set xlWS = Nothing
xlWB.Close True
Set xlWB = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub
Runtime error 6
ived tried reducing the amount of lines in the excel doc but that hasnt made any difference
I have a sheet that has names, SSNs and 4 columns filled with the following values: S, MB, B.
For said columns I wish to replace S with the number 4, MB with the number 3 and B with the number 2.
Sub replace()
Dim str1, str2, str3, filename, pathname As String
Dim i As Integer
str1 = "MB"
str2 = "B"
str3 = "S"
filename = "p"
pathname = ActiveWorkbook.Path
i = 1
Do While filename <> ""
Set wb = Workbooks.Open(pathname & filename + i)
DoWork wb
wb.Close SaveChanges:=True
filename = Dir()
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
End With
End Sub
In the function DoWork, how do I create a loop to replace each of the values?
I mostly agree with Michael--to learn the most, you should get started on your own, and come back with more specific questions. However, I am looking to reach 50 rep so I will pander to you. But do please try to go through the code and understand it.
Your name suggests you are a programmer, so the concepts we make use of should be familiar. I like to work from the inside out, so here goes:
here are my variables:
Dim sFileName As String
Dim sFilePath As String
Dim wbBook As Excel.Workbook
Dim i As Double
Dim wsSheet As Excel.Worksheet
Dim rRange As Range
Dim c As Range
Dim dReplace As Double
At the core, you'll want a select case statement to read each cell and decide what the new value should be. Then you will assign the new value to the cell:
Select Case c.value 'c being the cell we are currently examining
Case "S"
dReplace = 4
Case "M"
dReplace = 3
Case "B"
dReplace = 2
Case Else
'Assuming you should only encounter the above values,
'then anything else is an error
'.assert false will stop the code, or you can replace
'with more refined error handling
Debug.Assert False
End Select
c.value = dReplace
Around that you'll want a for each loop to define the current cell and iterate through all the cells in the range you specify for that particular worksheet:
set rRange = wsSheet.Range("C2:E5000") 'Customize to your range
for each c in rRange.Cells
'...
next
Next level up is the for next loop to iterate through all the worksheets in the current file:
For i = 1 To 30
If wbBook.Sheets(i).Name = "" Then
GoTo NextOne
End If
Set wsSheet = wbBook.Sheets(i)
'...
NextOne:
Next i
The if then statement at the top prevents an error if there are fewer than 30 worksheets in a workbook. If the number of sheets per file varies then this will be useful, if the number is fixed, just adjust the loop to stop and the right spot. Of course, this assumes your workbooks have information on multiple sheets. If not skip the loop altogether.
I'm sure many will criticize my use of goto, but since VBA loops lack a continue command, this is the workaround I employ.
Around that you'll want another iterator to loop through your multiple files. Assuming they are all in the same folder, you can use the Dir() function to grab the file names one-by-one. You give it the file path and (optionally) the file type, and it will return the first file name it finds that meets your cirteria. Run it again and it returns the second file name, etc. Assign that to a string variable, then use the file path plus the file name to open the workbook. Use a do loop to keep going until runs out of files:
sFilePath = "C:\Your File Path Here\"
sFileName = Dir(sFilePath & "*.xlsx")
Do Until sFileName = ""
Set wbBook = Workbooks.Open(sFilePath & sFileName)
'...
wbBook.Save
wbBook.Close
sFileName = Dir()
Loop
Now Put it all together:
Sub ReplaceLetterCodewithNumberCode()
Dim sFileName As String
Dim sFilePath As String
Dim wbBook As Excel.Workbook
Dim i As Double
Dim wsSheet As Excel.Worksheet
Dim rRange As Range
Dim c As Range
Dim dReplace As Double
Application.ScreenUpdating = False
sFilePath = "C:\Your File Path Here\"
sFileName = Dir(sFilePath & "*.xlsx")
Do Until sFileName = ""
Set wbBook = Workbooks.Open(sFilePath & sFileName)
For i = 1 To 30
If wbBook.Sheets(i).Name = "" Then
GoTo NextOne
End If
Set wsSheet = wbBook.Sheets(i)
Set rRange = wsSheet.Cells("C2:E5000") 'Customize to your range. Assumes the range will be the same
For Each c In rRange.Cells
Select Case c.value 'c being the cell we are currently examining
Case "S"
dReplace = 4
Case "M"
dReplace = 3
Case "B"
dReplace = 2
Case Else
'Assuming you should only encounter the above values,
'then anything else is an error
'.assert false will stop the code, or you can replace
'with more refined error handling
Debug.Assert False
End Select
c.value = dReplace
Next
NextOne:
Next i
wbBook.Save
wbBook.Close
sFileName = Dir()
Loop
'Clean up
Set wbBook = Nothing
Set wsSheet = Nothing
Set rRange = Nothing
Set c = Nothing
Application.ScreenUpdating = True
End Sub
I'll provide a high level explanation of this; implementation will be up to you. You'll start with a crawler to open all of these files one by one (a google search should help you with this).
I'm not exactly sure how your sheets are organized but the general idea is to open each sheet and perform the action, so you'll need a list of filenames/paths or do it sequentially. Then once inside the file assuming the structure is the same of each you'll grab the column and input the appropriate value then save and close the file.
If you're looking for how to open the VBA editor go to options and enable the Developer tab.
This is a good beginner project and while you may struggle you'll learn a lot in the process.