I am getting runtime error "interface is unknown".
I have used the code.
Don't know why I am getting this error.
Run-time error ‘-2147023179 (800706b5)”: Automation error The
interface is unkown.
Sub copy_sheet_from_folder(ws_the_tool As Workbook)
Dim source As String
Dim strFile As String
Dim wb_from As Workbook
source = ws_the_tool.Path
If InStr(1, source, "http") Then
Dim IE As InternetExplorerMedium
Set IE = New InternetExplorerMedium
IE.Visible = False
IE.Navigate source
Do While IE.ReadyState <> 4
DoEvents
Loop
IE.Quit
Set IE = Nothing
Dim bIsSSL As Boolean
bIsSSL = InStr(1, source, "https:") > 0
source = Replace(Replace(source, "/", "\"), "%20", " ")
source = Replace(Replace(source, "https:", vbNullString), "http:", vbNullString)
source = Replace(source, Split(source, "\")(2), Split(source, "\")(2) & "#SSL\DavWWWRoot")
If Not bIsSSL Then source = Replace(source, "#SSL\", vbNullString)
End If
source = source & "\measure_files\"
strFile = Dir(source)
Do While Len(strFile) > 0
Workbooks.Open Filename:=source & strFile
strFile = Dir()
Set wb_from = ActiveWorkbook
Call copy_sheets(ws_the_tool, wb_from)
wb_from.Close savechanges:=False
Loop
'Call copy_sheets(ws_the_tool)
End Sub
Please suggest why I am getting this error. I have searched this error message and can't find a solution that seems to work for me.
Related
I am trying to design a macro to search for multiple strings in an excel.
I have the following code which searches for the word "techno" in an excel but, I need to include a variable into the code so that I can search for multiple words such "Techno", "electromagnetic", "waves", etc. at once. I am unable to create a loop for this condition.
Can anyone suggest a solution to this problem? The below code works fine but, only a tweak is required to include multiple strings in the search.
Sub SearchFolders()
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
myArray = Array("techno", "magnetic", "laser", "trent")
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets.Add
For myCounter = 0 To UBound(myArray)
MsgBox myCounter & " is the Count No."
xStrSearch = myArray(myCounter)
MsgBox xStrSearch & " is the Value fr String search"
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Text in Cell"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch)
MsgBox xFound & " is the strings found"
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
MsgBox xCount & " is the count of strings"
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 4) = xFound.Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
MsgBox xFound & " next string"
MsgBox xStrAddress & " is the address "
MsgBox xFound.Address & " is the address found"
Loop While xStrAddress <> xFound.Address 'To check how xStrAddress is populated or do we need to declare it as a help from excel pointed out
myCounter = myCounter + 1
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
Next myCounter
MsgBox xCount & "cells have been found", ,
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
If the strings you are searching will always be the same, hard code them into an array and Loop through the array elements to search each string, like so:
Dim myArray as Variant
Dim myCounter as Long
myArray = Array("techno", "electromagnetic", ...etc.)
For myCounter = 0 To UBound(myArray)
... 'your code here
xStrSearch = myArray(myCounter)
... 'the rest if your code here
Next myCounter
I'm working on a macro that loops through all files in a folder, changes formulas that point to other workbooks to values, and saves and closes each file. I've merged two pieces of code from Ron de Bruin into the below macro. His code to break links and change to values works perfectly when it isn't in the loop but when I run this macro the files then don't have the info, they instead return "#N/A". What am I doing wrong?
Sub Formulas()
Const strSavePath As String = “MyFilePath"
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean
Dim Path1 As Range
Set Path1 = ThisWorkbook.Worksheets("Monthly Reporting").Range("E2")
Dim WorkbookLinks As Variant
Dim i As Long
MyPath = strSavePath & Path1 & "\"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
'Change cell value(s) in one worksheet in mybook
WorkbookLinks = mybook.LinkSources(Type:=xlLinkTypeExcelLinks)
If IsArray(WorkbookLinks) Then
For i = LBound(WorkbookLinks) To UBound(WorkbookLinks)
mybook.BreakLink _
Name:=WorkbookLinks(i), _
Type:=xlLinkTypeExcelLinks
Next i
Else
MsgBox "No Links to other workbooks"
End If
If Err.Number > 0 Then
ErrorYes = True
Err.Clear
'Save and close mybook
mybook.Close savechanges:=True
End If
On Error GoTo 0
Else
'Not possible to open the workbook
ErrorYes = True
End If
Next Fnum
End If
If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
I am a VBA novice and I am trying to print an array that I was able to make (basically copying from another post) in VBA today. I placed a break into the script and inspected the array in the locals page to see that the array captures what I want (and some extra data that I will filter out). I spent the day reading about printing arrays on stack overflow and other sites and I ended up a bit lost. My goal is to export the array as a table in excel.
The script looks for underlined sentences in a 400 page word document and places them into the array. All that's really necessary for printing is the underlined sentences, so maybe an array wasn't the best approach? How can I export the array 'myWords' to a fresh excel document or one that I designate?
Many thanks for your help!
Sub addUnderlinedWordsToArray()
On Error GoTo errhand:
Dim myWords() As String
Dim i As Long
Dim myDoc As Document: Set myDoc = ActiveDocument ' Change as needed
Dim aRange As Range: Set aRange = myDoc.Content
Dim sRanges As StoryRanges: Set sRanges = myDoc.StoryRanges
Dim ArrayCounter As Long: ArrayCounter = 0 ' counter for items added to the array
Dim Sentence As Range
Dim w As Variant
Application.ScreenUpdating = False
ReDim myWords(aRange.Words.Count) ' set a array as large as the
' number of words in the doc
For Each Sentence In ActiveDocument.StoryRanges
For Each w In ActiveDocument.Sentences
If w.Font.Underline <> wdUnderlineNone Then
myWords(ArrayCounter) = w
ArrayCounter = ArrayCounter + 1
End If
Next
Next
Set myDoc = Nothing
Set aRange = Nothing
Set sRange = Nothing
Application.ScreenUpdating = True
Exit Sub
errhand:
Application.ScreenUpdating = True
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
End Sub
I prefer to use Late Binding over adding an external reference to Excel. This will allow the code to work properly no mater what version of Office is installed.
Sub addUnderlinedWordsToArray()
On Error GoTo errhand:
Dim myWords() As String
Dim i As Long
Dim myDoc As Document: Set myDoc = ActiveDocument ' Change as needed
Dim aRange As Range: Set aRange = myDoc.Content
Dim sRanges As StoryRanges: Set sRanges = myDoc.StoryRanges
Dim ArrayCounter As Long: ArrayCounter = 0 ' counter for items added to the array
Dim Sentence As Range
Dim w As Variant
Application.ScreenUpdating = False
ReDim myWords(aRange.Words.Count) ' set a array as large as the
' number of words in the doc
For Each Sentence In ActiveDocument.StoryRanges
For Each w In ActiveDocument.Sentences
If w.Font.Underline <> wdUnderlineNone Then
myWords(ArrayCounter) = w
ArrayCounter = ArrayCounter + 1
End If
Next
Next
ReDim Preserve myWords(ArrayCounter - 1)
AddWordsToExcel myWords
Set myDoc = Nothing
Set aRange = Nothing
Set sRange = Nothing
Application.ScreenUpdating = True
Exit Sub
errhand:
Application.ScreenUpdating = True
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
End Sub
Sub AddWordsToExcel(myWords() As String)
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Dim wb As Object
Set wb = xlApp.Workbooks.Add
wb.Worksheets(1).Range("A1").Resize(UBound(myWords) + 1).Value = xlApp.Transpose(myWords)
xlApp.Visible = True
End Sub
This is tested and working fine :
Option Explicit
Sub addUnderlinedWordsToArray()
Dim myWords() As String
Dim i As Long
Dim myDoc As Document: Set myDoc = ActiveDocument ' Change as needed
Dim aRange As Range: Set aRange = myDoc.Content
Dim sRanges As StoryRanges: Set sRanges = myDoc.StoryRanges
Dim ArrayCounter As Long: ArrayCounter = 0 ' counter for items added to the array
Dim Sentence As Range
Dim w As Variant
Dim Ex0 As Excel.Application
Dim Wb0 As Workbook
Application.ScreenUpdating = False
On Error GoTo errhand:
For Each Sentence In ActiveDocument.StoryRanges
For Each w In ActiveDocument.Sentences
If w.Font.Underline <> wdUnderlineNone Then
ReDim Preserve myWords(ArrayCounter)
myWords(ArrayCounter) = w
ArrayCounter = ArrayCounter + 1
End If
Next
Next
On Error GoTo 0
Set myDoc = Nothing
Set aRange = Nothing
Set sRanges = Nothing
Set Ex0 = New Excel.Application
Set Wb0 = Ex0.workbooks.Add
Ex0.Visible = True
Wb0.Sheets(1).Range("A1").Resize(UBound(myWords) + 1, 1) = WorksheetFunction.Transpose(myWords)
Application.ScreenUpdating = True
Debug.Print UBound(myWords())
Exit Sub
errhand:
Application.ScreenUpdating = True
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
End Sub
Make sure to have the Microsoft Excel 14.0 Object Library ticked in Tools/References
The code provided in the question has some problems, which I've tried to correct as per the problem description.
The code declares a number of object variables, assigning them in the same line as the declaration, but these objects are never used. In order to improve code readability and make these objects "obvious" I've moved the instantiations to new lines.
The sample code below then substitutes these objects for the ActiveDocument... objects used in the original code, where these objects are intended to be used. This makes the code more readabile and more efficient.
The use of StoryRanges is questionable in the context of the code. StoryRanges are not the same as Sentences. On the assumption that the use of StoryRanges was a misunderstanding or typo, I've changed the code to use Sentences. If StoryRanges is meant, the code can loop through them, but certain structural changes would be required. (StoryRanges enables code to access all parts of a document such as TextBoxes, Headers, Footers, Endnotes - instead of just the main body of the document.)
It makes no sense to loop sentences while sizing the array to the number of words in the document. This has been changed to the number of sentences, which will require less memory.
Only the text, not the entire sentence Range should be added to the array since Excel can't do anything with a Word.Range except accept its text. This will require less memory.
On the assumption that not every sentence in the document is underlined, it's not necessary to maintain an array with empty members, so after the loop the array is resized to contain only those that have been populated. (ReDim Preserve myWords(ArrayCounter - 1)). This will avoid writing "empty" content to the Excel worksheet.
The code to write to Excel is in a separate procedure, making it re-usable for other arrays that might need to be transferred to Excel. The code has been written as late-binding, making it independent of requiring a reference to the Excel library. If early-binding (with a reference) is desired, those declarations are commented out in-line.
The writing to Excel only occurs if the array contains members. If ArrayCounter has never been incremented, the call to the other procedure is not performed.
The Excel objects are set to Nothing at the end of that procedure.
Note: The code posted in the question and used here picks up any sentence that contains an underline.
Sample code:
Sub addUnderlinedWordsToArray()
On Error GoTo errhand:
Dim myWords() As String
Dim i As Long
Dim myDoc As Document
Dim aRange As Range
Dim sRanges As Sentences
Dim ArrayCounter As Long ' counter for items added to the array
Dim Sentence As Range
Dim w As Variant
Application.ScreenUpdating = False
Set myDoc = ActiveDocument ' Change as needed
Set aRange = myDoc.content
Set sRanges = myDoc.Sentences
ArrayCounter = 0
ReDim myWords(aRange.Sentences.Count - 1) ' set a array as large as the
' number of sentences in the doc
For Each Sentence In sRanges
If Sentence.Font.Underline <> wdUnderlineNone Then
myWords(ArrayCounter) = Sentence.text
ArrayCounter = ArrayCounter + 1
End If
Next
If ArrayCounter > 0 Then
ReDim Preserve myWords(ArrayCounter - 1)
WriteToExcel myWords
End If
Set myDoc = Nothing
Set aRange = Nothing
Set sRanges = Nothing
Application.ScreenUpdating = True
Exit Sub
errhand:
Application.ScreenUpdating = True
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
End Sub
Sub WriteToExcel(a As Variant)
Dim appExcel As Object 'Excel.Application
Dim wb As Object ' Excel.Workbook
Dim r As Object ' Excel.Range
Dim i As Long
Set appExcel = CreateObject("Excel.Application")
appExcel.Visible = True
appExcel.UserControl = True
Set wb = appExcel.Workbooks.Add
Set r = wb.Worksheets(1).Range("A1")
r.Resize(UBound(myWords) + 1).Value = xlApp.Transpose(myWords)
Set r = Nothing
Set wb = Nothing
Set appExcel = Nothing
End Sub
The general answer is to use Range ("A1") = myWords(ArrayCounter)
You would need to step through the array while simultaneously moving to the next cell.
You could also use Range ("A1:B3") = myWords.
I have a query in Ms Access that runs with 227,288 rows. I made a command button which can export the query into Excel. I've searched and found this code
Private Sub Export_Click()
Dim rst As DAO.Recordset
Dim excelApp As Object
Dim sht As Object
Dim fldHeadings As DAO.Field
Set rst = CurrentDb.OpenRecordset("acct file", dbOpenDynaset)
Set excelApp = CreateObject("Excel.Application")
On Error Resume Next
Set Wbk = excelApp.Workbooks.Open(book1)
If Err.Number <> 0 Or Len(book1) = 0 Then
Set Wbk = excelApp.Workbooks.Add
Set sht = Wbk.Worksheets("CSC Landed")
If Len(sheet1) > 0 Then
sht.Name = Left("acct file", 34)
End If
End If
Set sht = Wbk.Worksheets.Add
If Len(sheet1) > 0 Then
sht.Name = Left("acct file", 34)
End If
On Error GoTo 0
excelApp.Visible = True
On Error GoTo Errorhandler
For Each fldHeadings In rst.Fields
excelApp.ActiveCell = fldHeadings.Name
excelApp.ActiveCell.Offset(0, 1).Select
Next
rst.MoveFirst
sht.Range("A2").CopyFromRecordset rst
sht.Range("1:1").Select
excelApp.Selection.Font.Bold = True
With excelApp.Selection
.HorizontalAlignment = -4108
.VerticalAlignment = -4108
.WrapText = False
With .Font
.Name = "Arial"
.Size = 10
End With
End With
excelApp.ActiveSheet.Cells.EntireColumn.AutoFit
With excelApp.ActiveWindow
.FreezePanes = False
.ScrollRow = 1
.ScrollColumn = 1
End With
sht.Rows("2:2").Select
excelApp.ActiveWindow.FreezePanes = True
With sht
.Tab.Color = RGB(255, 0, 0)
.Range("A1").Select
End With
rst.Close
Set rst = Nothing
Exit Sub
Errorhandler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Exit Sub
End Sub
However, when export is done it only exports 496 rows. I've search and tried different attempts, still the rows I'm getting is only 496. I'm also looking into preferences in VB.
I'm very new in Access. I've done several research but still I couldn't do it.
(Posted on behalf of the OP).
I've got it working by
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _
"acct file", "C:\Users\user\Desktop\acctfile.xlsx", True
Assuming that you're running the Export_Click code from within Microsoft Access, you can use the following code to invoke the "Output To" action of the DoCmd object:
Private Sub Export_Click()
DoCmd.OutputTo acOutputQuery, "acct file", acFormatXLSX, , True
End Sub
I need to replace 108 images in word. I wrote VBA code so that for each inline image read in the document, the image will be replace by a new image. The new image is specified by a array that has filepaths in each element. The array comes from a text file.
For some reason, my code won't work if I have my variable, strPath as
strPath = dataArray(i)
or
strPath = Chr(34) & dataArray(i) & Chr(34)
What does work is if I type in
dataArray(0) = "C:\IMGS\G.2.1\NZ_DWH_v_SIMAP_AR1_biovalbox1_1100-1400m_Apr20-May26.png"
The path in the textfile is
C:\IMGS\G.2.1\NZ_DWH_v_SIMAP_AR1_biovalbox1_1100-1400m_Apr20-May26.png
I have 108 lines in the textfile, each for the image that needs to be replaced.
I have displayed the path in a message box and it looks like the above, so I am not sure why I can't get file paths from an array. Can someone help me?
'1-loop thru all figs
'2-bring up box to select figure
'3-add figure
Dim intChoice As Integer
Dim strPath As String
Dim objPic As InlineShape
Dim intCount As Integer
'import text
Dim dataArray() As String
Dim i As Integer
Dim g As Integer
strFileName = "C:\Users\cturner\Desktop\filesimgs_order.txt"
Open strFileName For Input As #1
dataArray = Split(Input$(LOF(1), #1), vbLf)
Close #1
g = 0
intCount = ActiveDocument.InlineShapes.Count
'loop through inline shapes
For i = 0 To intCount
strPath = Chr(34) & dataArray(i) & Chr(34)
MsgBox (TypeName(strPath))
g = g + 1
'check if valid filepath
'Debug.Print FileExists(strPath)
MsgBox strPath
'check if the current shape is an picture
If ActiveDocument.InlineShapes.Item(g).Type = wdInlineShapePicture Then
Set objPic = ActiveDocument.InlineShapes.Item(g)
objPic.Select
'insert the image
Selection.InlineShapes.AddPicture FileName:= strPath, _
LinkToFile:=False, SaveWithDocument:=True
End If
Next i
End Sub
Suprise Suprise, I forgot to trim the carriage return vbCr. After I got that out, code works fine and I am able to replace my buttload of images.
Part 1. I checked my string if it has carriage return. Main problem is that I didn't clean my string, and thus putting it into a function made vba throw the error message (no bueno). If you have it, UBound should = 1
For i = 0 To 2
strPath = dataArray(i)
checkcr = Split(strPath, vbCr)
firstIndex = LBound(checkcr)
lastIndex = UBound(checkcr)
MsgBox (firstIndex)
MsgBox (lastIndex)
MsgBox checkcr(lastIndex)
newstrPath = Replace(strPath, vbCr, "")
MsgBox newstrPath
Next i
Part 2. Corrected Code + bonus. Bouns: some code to check if the file exists (from here )
fix:
newstrPath = Replace(strPath, vbCr, "")
Updated Code:
Sub replacefigs()
' replacefigs Macro
' To replace old figures with new figures (updated disclosure)
'0-get full file paths from textfile
'1-loop thru all figs
'2-bring up box to select figure
'3-add figure
Dim intChoice As Integer
Dim strPath As String
Dim objPic As InlineShape
Dim intCount As Integer
'import text
Dim dataArray() As String
Dim i As Integer
Dim g As Integer
strFileName = "C:\Users\cturner\Desktop\filesimgs_order.txt"
Open strFileName For Input As #1
dataArray = Split(Input$(LOF(1), #1), vbLf)
Close #1
g = 0
intCount = ActiveDocument.InlineShapes.Count
'loop through inline shapes
For i = 0 To intCount
strPath = dataArray(i)
'Get rid of carriage returns
newstrPath = Replace(strPath, vbCr, "")
g = g + 1
'to check if file exists
'Debug.Print FileExists(newstrPath)
'check if the current shape is an picture
If ActiveDocument.InlineShapes.Item(g).Type = _
wdInlineShapePicture Then
Set objPic = ActiveDocument.InlineShapes.Item(g)
objPic.Select
'insert the image
Selection.InlineShapes.AddPicture FileName:= _
newstrPath, LinkToFile:=False, _
SaveWithDocument:=True
End If
Next i
End Sub