i currently have the problem that everytime im trying to open a word document via vba/excel im getting an Application/Object Error. My Idea is that im trying to compare data from two tables and deleting the bad results. After that i want to insert the whole table to the existing word document what im selecting from the selection/opening window.
My Code
Private Sub CommandButton1_Click()
Dim varDatei As Variant
Dim wordDatei As Variant
Dim objExcel As New Excel.Application
Dim objSheet As Object
Dim wordDoc As Object
Dim extBereich As Variant
Dim intBereich As Variant
Dim appWord As Object
Set intBereich = ThisWorkbook.Sheets(1).Range("A4:A11")
Dim loopStr As Variant
Dim loopStr2 As Variant
Dim found() As Variant
Dim loopInt As Integer
Dim endStr As Variant
Dim extBereich2 As Variant
loopInt = 1
varDatei = Application.GetOpenFilename("Excel-Dateien (*.xlsx), *.xlsx")
If varDatei <> False Then
objExcel.Workbooks.Open varDatei
Set objSheets = objExcel.Sheets(1)
objSheets.Activate
LetzteZeile = objSheets.Cells(objSheets.Rows.Count, 3).End(xlUp).Row
Set extBereich = objSheets.Range("B3:B" & LetzteZeile)
ReDim found(1 To LetzteZeile)
For Each loopStr In extBereich
objSheets.Range("F" & loopStr.Row) = "Good"
objSheets.Cells(loopStr.Row, 6).Interior.ColorIndex = 4
For Each loopStr2 In intBereich
If (StrComp(loopStr, loopStr2, vbBinaryCompare) = 0) = True Then
found(loopInt) = objSheets.Range("A" & loopStr.Row)
loopInt = loopInt + 1
objSheets.Cells(loopStr.Row, 6) = "Bad"
objSheets.Cells(loopStr.Row, 6).Interior.ColorIndex = 3
Exit For
End If
Next loopStr2
Next loopStr
loopStr = ""
If (loopInt <> 1) Then
endStr = "This is bad:" & vbLf
For Each loopStr In found
If (Trim(loopStr & vbNullString) <> vbNullString) Then
endStr = endStr & loopStr & vbLf
End If
Next loopStr
MsgBox (endStr)
Else
MsgBox ("Everythings good")
End If
Set appWord = CreateObject("Word.Application")
appWord.DisplayAlerts = False
Debug.Print ("123")
Set wordDoc = appWord.Documents.Open(Application.GetOpenFilename("Word-Dateien (*.doc;*.docx;),*.doc;*.docx"))
wordDoc.Activate
Debug.Print ("456")
loopStr = ""
For Each loopStr In extBereich
If (objSheets.Cells(loopStr.Row, 6).Interior.ColorIndex = 3) Then
objSheets.Range("A" & loopStr.Row & ":" & "E" & loopStr.Row).Delete
End If
Next loopStr
objSheets.Range(Columns(2), Columns(4)).Delete
objSheets.Range("A3:B" & LetzteZeile).Copy
appWord.Documents(1).Range.Paste
With appWord.Documents(1).Tables(1)
.Columns.AutoFit
End With
appWord.PrintOut
objExcel.Quit
appWord.Quit
Set appWord = Nothing
Set objExcel = Nothing
Debug.Print loopInt
Else
MsgBox "Error"
End If
End Sub
Maybe someone of you knew whats the problem?
Error Code is 1004 - Application- or object Error
With best regards and thanks for answering
Your problem is with the line:
objSheets.Range(Columns(2), Columns(4)).Delete
You need to specify where the columns are, e.g.
objSheets.Range(objSheets.Columns(2), objSheets.Columns(4)).Delete
Related
I have below code which prints text from a column but open a text file many times instead of once. Please let me know what is the wrong.
When I run sub in Visual Basic debug mode, it open text file only once. But I am calling this macro after another macro and that time it is opening (same) text file many times.
Sub createdevtest()
Dim filename As String, lineText As String
Dim data As Range
Dim myrng As Range, i, j
' filename = ThisWorkbook.Path & "\textfile-" & Format(Now, "ddmmyy-hhmmss") & ".txt"
filename = ThisWorkbook.Path & "\devtest" & ".txt"
Open filename For Output As #1
Dim LastRow As Long
'Find the last non-blank cell in column A(1)
LastRow = Cells(Rows.count, 1).End(xlUp).Row
Range("B4:B" & LastRow).Select
Set myrng = Selection
For i = 1 To myrng.Rows.count
For j = 1 To myrng.Columns.count
lineText = IIf(j = 1, "", lineText & ",") & myrng.Cells(i, j)
Next j
Print #1, lineText
Next i
Close #1
Range("B4").Select
' open devtest
'Shell "explorer.exe" & " " & ThisWorkbook.Path, vbNormalFocus
filename = Shell("Notepad.exe " & filename, vbNormalFocus)
End Sub
Thanks #Luuklag. I had tried to figure out on my own but no success. After your comment, just went thru code again and got clue.
Below is the correct code where I have called one of the macro (devtest1) which contains above text file creation macro (createdevtest). Before correction I was calling macro in function instead of Sub, so it was looping again and opening txt file many times.
' macro to select folder and list files
Sub GetFileNames_devtest()
Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
If Folder.Show <> -1 Then Exit Sub
xDir = Folder.SelectedItems(1)
Call ListFilesInFolder(xDir, True)
' call devtest: corrected to call macro at right place
devtest1
End Sub
Sub ListFilesInFolder(ByVal xFolderName As String, ByVal xIsSubfolders As Boolean)
Dim xFileSystemObject As Object
Dim xFolder As Object
Dim xSubFolder As Object
Dim xFile As Object
Dim rowIndex As Long
Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFileSystemObject.GetFolder(xFolderName)
rowIndex = Application.ActiveSheet.Range("A65536").End(xlUp).Row + 1
For Each xFile In xFolder.Files
Application.ActiveSheet.Cells(rowIndex, 1).Formula = xFile.Name
rowIndex = rowIndex + 1
Next xFile
If xIsSubfolders Then
For Each xSubFolder In xFolder.SubFolders
ListFilesInFolder xSubFolder.Path, True
Next xSubFolder
End If
Set xFile = Nothing
Set xFolder = Nothing
Set xFileSystemObject = Nothing
'' Was calling wrongly macro here
End Sub
Function GetFileOwner(ByVal xPath As String, ByVal xName As String)
Dim xFolder As Object
Dim xFolderItem As Object
Dim xShell As Object
xName = StrConv(xName, vbUnicode)
xPath = StrConv(xPath, vbUnicode)
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.Namespace(StrConv(xPath, vbFromUnicode))
If Not xFolder Is Nothing Then
Set xFolderItem = xFolder.ParseName(StrConv(xName, vbFromUnicode))
End If
If Not xFolderItem Is Nothing Then
GetFileOwner = xFolder.GetDetailsOf(xFolderItem, 8)
Else
GetFileOwner = ""
End If
Set xShell = Nothing
Set xFolder = Nothing
Set xFolderItem = Nothing
End Function
End Function
I have a form in ms word with some of the fields are content control and some (which are the radio buttons) are ActiveX control. I want to automatically transfer hundred word forms to an excel file. I use the following vba code:
Sub getWordFormData()
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim CCtl As Word.ContentControl
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long
myFolder = "C:\Users\alarfajal\Desktop\myform"
Application.ScreenUpdating = False
If myFolder = "" Then Exit Sub
Set myWkSht = ActiveSheet
ActiveSheet.Cells.Clear
Range("A1") = "name"
Range("a1").Font.Bold = True
Range("B1") = "age"
Range("B1").Font.Bold = True
Range("C1") = "gender"
Range("C1").Font.Bold = True
Range("D1") = "checkbox1"
Range("D1").Font.Bold = True
Range("E1") = "checkbox2"
Range("E1").Font.Bold = True
Range("F1") = "singlechoice1"
Range("F1").Font.Bold = True
Range("G1") = "singlechoice2"
Range("G1").Font.Bold = True
i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(myFolder & "\*.docx", vbNormal)
While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With myDoc
j = 0
For Each CCtl In .ContentControls
j = j + 1
myWkSht.Cells(i, j) = CCtl.Range.Text
Next
myWkSht.Columns.AutoFit
End With
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing
Application.ScreenUpdating = True
End Sub
all the data (text fields, checkbox) are transferred successfully but, the radio button (which is ActiveX) is not transferred.
This is the word doc:
This is the excel result:
How can I solve this problem?
You can refer to an ActiveX control on a Word document by it's name
myDoc.singlechoice1.Value
It is better to refer to the ContentControls by their tag names.
myDoc.SelectContentControlsByTag("name").Item(1).Range.Text
Refactored Code
Sub getWordFormData()
Dim wdApp As Object, myDoc As Object
Dim myFolder As String, strFile As String
Dim i As Long, j As Long
myFolder = "C:\Users\alarfajal\Desktop\myform"
If Len(Dir(myFolder)) = 0 Then
MsgBox myFolder & vbCrLf & "Not Found", vbInformation, "Cancelled - getWordFormData"
Exit Sub
End If
Application.ScreenUpdating = False
Set wdApp = CreateObject("Word.Application")
With ActiveSheet
.Cells.Clear
With .Range("A1:G1")
.Value = Array("name", "age", "gender", "checkbox1", "checkbox2", "singlechoice1", "singlechoice2")
.Font.Bold = True
End With
strFile = Dir(myFolder & "\*.docx", vbNormal)
i = 1
While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
.Cells(i, 1).Value = myDoc.SelectContentControlsByTag("name").Item(1).Range.Text
.Cells(i, 2).Value = myDoc.SelectContentControlsByTag("age").Item(1).Range.Text
.Cells(i, 3).Value = myDoc.SelectContentControlsByTag("gender").Item(1).Range.Text
.Cells(i, 4).Value = myDoc.SelectContentControlsByTag("checkbox1").Item(1).Checked
.Cells(i, 5).Value = myDoc.SelectContentControlsByTag("checkbox2").Item(1).Checked
.Cells(i, 6).Value = myDoc.singlechoice1.Value
.Cells(i, 7).Value = myDoc.singlechoice2.Value
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Application.ScreenUpdating = True
End With
End Sub
Your radiobuttons are inlineshapes so you need a separate loop for them
to keep in line with your current code, it would be something like
Dim shp As InlineShape
For Each shp In .InlineShapes
j = j + 1
myWkSht.Cells(i, j) = shp.OLEFormat.Object.Value
Next shp
However I wouldn't want to rely on Word always giving me the right order and there could be other inlineshapes so it might be better to check the controls first:
With myDoc
'content controls
For Each CCtl In .ContentControls
Select Case CCtl.Title
Case "name"
myWkSht.Cells(i, 1) = CCtl.Range.Text
'similar for age and gender
Case "checkbox1"
myWkSht.Cells(i, 4) = CCtl.Checked 'true and false are easier to evaluate in Excel than the checkmark symbols
'same for checkbox 2
End Select
Next CCtl
'option buttons
For Each shp In .InlineShapes
If shp.Type = wdInlineShapeOLEControlObject Then 'skip other inlineshapes
Select Case shp.OLEFormat.Object.Name
Case "singleSelectQuestionOption1" 'name it something unique
myWkSht.Cells(i, 6) = shp.OLEFormat.Object.Value
'similar for option button 2
End Select
End If
Next shp
End With
I was working with a vba and I'm trying to open all excel files in a folder (about 8-10) based on cell values. I was wondering if this is the right approach to opening it, it keeps giving me syntax error where I wrote the directory. and when I rewrote that section, the vba only shot out the msgbox which meant it had to have looped and did something right? but didn't open any files. Any information will help. Thank you guys so much for taking the time to help me in any way.
Sub OpenFiles()
Dim search As Worksheet
Dim customer As Range
Dim customerfolder As Range
Dim QualityHUB As Workbook
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = Worksheets("Search")
Set customer = Worksheets("Search").Range("$D$1")
Set customerfolder = Worksheets("Search").Range("$D$3")
With QualityHUB
If IsEmpty((customer)) And IsEmpty((customerfolder)) Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
End With
With QualityHUB
Dim MyFolder As String
Dim MyFile As String
Dim Directory As String
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder"
MyFile = Dir(Directory & "*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End With
End Sub
This worked for me perfectly
Sub OpenFiles()
Dim search As Worksheet
Dim customer As Range
Dim customerfolder As Range
Dim QualityHUB As Workbook
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = Worksheets("Search")
Set customer = Worksheets("Search").Range("$D$1")
Set customerfolder = Worksheets("Search").Range("$D$3")
With QualityHUB
If IsEmpty((customer)) And IsEmpty((customerfolder)) Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
End With
With QualityHUB
Dim MyFolder As String
Dim MyFile As String
Dim Directory As String
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder & "\"
MyFile = Dir(Directory & "*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=Directory & MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End With
End Sub
one of the issue was, you had to write
Workbooks.Open Filename:=Directory & MyFile
instead of
Workbooks.Open Filename:=MyFile
Corrected some issues with your code and cleaned it up, give this a try. I think the big issue was you had an extra double-quote, and you missing the ending \ in the Directory line:
Sub OpenFiles()
Dim QualityHUB As Workbook
Dim search As Worksheet
Dim customer As String
Dim customerfolder As String
Dim Directory As String
Dim MyFile As String
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = QualityHUB.Worksheets("Search")
customer = search.Range("$D$1").Value
customerfolder = search.Range("$D$3").Value
If Len(Trim(customer)) = 0 Or Len(Trim(customerfolder)) = 0 Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder & "\" '<--- This requires the ending \
MyFile = Dir(Directory & "*.xlsx")
Do While Len(MyFile) > 0
Workbooks.Open Filename:=Directory & MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End Sub
I found this code online and it will open all the excel files in a folder, you can adapt the code to apply a function to the workbook, once it is open.
Option Explicit
Type FoundFileInfo
sPath As String
sName As String
End Type
Sub find()
Dim iFilesNum As Integer
Dim iCount As Integer
Dim recMyFiles() As FoundFileInfo
Dim blFilesFound As Boolean
blFilesFound = FindFiles("G:\LOCATION OF FOLDER HERE\", _
recMyFiles, iFilesNum, "*.xlsx", True)
End Sub
Function FindFiles(ByVal sPath As String, _
ByRef recFoundFiles() As FoundFileInfo, _
ByRef iFilesFound As Integer, _
Optional ByVal sFileSpec As String = "*.*", _
Optional ByVal blIncludeSubFolders As Boolean = False) As Boolean
Dim iCount As Integer '* Multipurpose counter
Dim sFileName As String '* Found file name
Dim wbResults, file, WS_Count, i, gcell, col, finRow, wbCodeBook As Workbook, lCount, name, looper
Dim WorksheetExists
Set wbCodeBook = ThisWorkbook
'*
'* FileSystem objects
Dim oFileSystem As Object, _
oParentFolder As Object, _
oFolder As Object, _
oFile As Object
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set oParentFolder = oFileSystem.GetFolder(sPath)
If oParentFolder Is Nothing Then
FindFiles = False
On Error GoTo 0
Set oParentFolder = Nothing
Set oFileSystem = Nothing
Exit Function
End If
sPath = IIf(Right(sPath, 1) = "\", sPath, sPath & "\")
'*
'* Find files
sFileName = Dir(sPath & sFileSpec, vbNormal)
If sFileName <> "" Then
For Each oFile In oParentFolder.Files
If LCase(oFile.name) Like LCase(sFileSpec) Then
iCount = UBound(recFoundFiles)
iCount = iCount + 1
ReDim Preserve recFoundFiles(1 To iCount)
file = sPath & oFile.name
name = oFile.name
End If
On Error GoTo nextfile:
Set wbResults = Workbooks.Open(Filename:=file, UpdateLinks:=0)
''insert your code here
wbResults.Close SaveChanges:=False
nextfile:
Next oFile
Set oFile = Nothing '* Although it is nothing
End If
If blIncludeSubFolders Then
'*
'* Select next sub-forbers
For Each oFolder In oParentFolder.SubFolders
FindFiles oFolder.path, recFoundFiles, iFilesFound, sFileSpec, blIncludeSubFolders
Next
End If
FindFiles = UBound(recFoundFiles) > 0
iFilesFound = UBound(recFoundFiles)
On Error GoTo 0
'*
'* Clean-up
Set oFolder = Nothing '* Although it is nothing
Set oParentFolder = Nothing
Set oFileSystem = Nothing
End Function
Function SSCGetColumnCodeFromIndex(colIndex As Variant) As String
Dim tstr As String
Dim prefixInt As Integer
Dim suffixInt As Integer
prefixInt = Int(colIndex / 26)
suffixInt = colIndex Mod 26
If prefixInt = 0 Then
tstr = ""
Else
prefixInt = prefixInt - 1
tstr = Chr(65 + prefixInt)
End If
tstr = tstr + Chr(65 + suffixInt)
SSCGetColumnCodeFromIndex = tstr
End Function
Function GetColNum(oSheet As Worksheet, name As String)
Dim Endrow_Col, i
'For loop to get the column number of name
Endrow_Col = oSheet.Range("A1").End(xlToRight).Column
oSheet.Select
oSheet.Range("A1").Select
For i = 0 To Endrow_Col - 1 Step 1
If ActiveCell.Value <> name Then
ActiveCell.Offset(0, 1).Select
ElseIf ActiveCell.Value = name Then
GetColNum = ActiveCell.Column
Exit For
End If
Next i
End Function
Function ShDel(name As String)
End If
End Function
I have a workbook which creates Word reports based on a Word template and tables in the workbook.
Depending on the equipment type, it copies a range from the spreadsheet and pastes it to two bookmark locations in the word document (bmInternal and bmExternal). I tried using PasteAppendTable, but this only works once. If I try to use it twice, for each bookmark, it copies nothing both times. As such I used Paste for one and PasteAppendTable for the second (PasteAppendTable is much neater as the formatting is better).
This worked fine, but I made changes to the code, not related to this, and now the Paste (which goes to bmInternal) isn't working. I can't see why when I've not changed anything regarding that part:
Sub Data2Word()
Application.GoTo Reference:=ActiveSheet.Range("A2")
GoAgain:
On Error Resume Next
Dim vItem As String
'Dim vImagePath As String
Dim vCurrentRow As Integer
Dim vDesc As String
Dim vN2 As String
Dim vGuide As String
Dim vUnit As String
Dim vBlock As String
Dim wrdPic As Word.InlineShape
Dim rng As Excel.Range 'our source range
Dim rngText As Variant
Dim rngText2 As Variant
Dim wdApp As New Word.Application 'a new instance of Word
Dim wdDoc As Word.Document 'our new Word template
Dim myWordFile As String 'path to Word template
Dim wsExcel As Worksheet
Dim tmpAut
'Find Item and type
vItem = ActiveCell.Value
vDesc = ActiveCell.Offset(0, 2)
vN2 = ActiveCell.Offset(0, 1)
vGuide = ActiveCell.Offset(0, 3)
vBlock = ActiveCell.Offset(0, 4)
vUnit = Left(vItem, 3)
If ActiveSheet.Range("rngREPORTED") = "Yes" Then
MsgBox vItem & " already has a report."
Exit Sub
End If
'initialize the Word template path
'here, it's set to be in the same directory as our source workbook
myWordFile = "W:\Entity\Inspect\WORD\INSPECTION TEMPLATES\Inspection Template - 20160511.dotx"
'open a new word document from the template
Set wdDoc = wdApp.Documents.Add(myWordFile)
If vGuide = "IGE01" Then
rngText = "rngEXCH"
rngText2 = "rngEXCHE"
ElseIf ActiveCell.Offset(, 4) = "Mono" Then
'Do Mono
rngText = "rngMONO"
Else
ActiveWorkbook.Names.Add Name:="rngItemSub", RefersTo:=Worksheets("SubEquipment").Range("B" & ActiveCell.Offset(0, 6) & ":C" & ActiveCell.Offset(0, 7) + ActiveCell.Offset(0, 6))
CarryOn:
rngText = "rngItemSub"
End If
'Insert Tables
'get the range of the data
Set rng = Range(rngText)
rng.Copy 'copy the range
wdDoc.Bookmarks("bmInternal").Range.Paste 'AppendTable
If vGuide = "IGE01" Then
Set rng = Range(rngText2)
rng.Copy
End If
wdDoc.Bookmarks("bmExternal").Range.PasteAppendTable
wdDoc.Bookmarks("bmItem").Range.InsertAfter vItem
wdDoc.Bookmarks("bmDesc").Range.InsertAfter vDesc
wdDoc.Bookmarks("bmN2").Range.InsertAfter vN2
wdDoc.Bookmarks("bmGuide").Range.InsertAfter vGuide
wdDoc.Bookmarks("bmBlock").Range.InsertAfter vBlock
wdDoc.Variables("wvItem").Value = vItem
ActiveDocument.Fields.Update
With wdDoc
Set wrdPic = .Bookmarks("bmImage").Range.InlineShapes.AddOLEObject(ClassType:="AcroExch.Document.7", Filename:="W:\Entity\Inspect\T&I\2016\Various Items\Photos\Sorted\" & vItem & ".pdf", LinkToFile:=False, DisplayAsIcon:=False)
wrdPic.ScaleHeight = 55
wrdPic.ScaleWidth = 55
End With
wdApp.Visible = True
wdApp.Activate
wdDoc.SaveAs "W:\Entity\Inspect\WSDATA\REPORTS\2016\" & vUnit & "\" & vItem & " " & vN2 & " THO.docx" 'Mid(ActiveDocument.Name, 1, Len(ActiveDocument.Name) - 4)
MoveHere:
ActiveWorkbook.Sheets("AllItems").Range("G" & ActiveCell.Offset(0, 8)).Value = "Yes"
ActiveWorkbook.Save
End Sub
I think DocVariables are easier to use that Bookmarks. Do a quick Google search on Word DocVariables. Get things setup correct in Word, and then run the script below.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
'On Error Resume Next
objWord.ActiveDocument.variables("FirstName").Value = Range("FirstName").Value
objWord.ActiveDocument.variables("LastName").Value = Range("LastName").Value
objWord.ActiveDocument.variables("AnotherVariable").Value = Range("AnotherVariable").Value
objWord.ActiveDocument.Fields.Update
'On Error Resume Next
objWord.Visible = True
End Sub
After much struggle with syntax, I have following code working, but I want to use error checking to determine if file is already open using a string.
(Disclosure: I have copied comparesheets from source that I will link when I find it)
Trying to replace this code
Set wbkA = Workbooks.Open(FileName:=wba)
with
Set wBook = Workbooks(wba) 'run time error subscript out of range
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(FileName:=wba)
End If
But I have syntax problem with the string wba. What is proper way use string here?
Sub RunCompare_WS2()
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wBook As Workbook
wba = "C:\c.xlsm"
wbb = "C:\d.xlsm"
'Set wBook = Workbooks(FileName:=wba) 'compiler error named argument not found
'Set wBook = Workbooks(wba) 'run time error subscript out of range
'If wBook Is Nothing Then
'Set wbkA = Workbooks.Open(FileName:=wba)
'End If
Set wbkA = Workbooks.Open(FileName:=wba)
Set wbkB = Workbooks.Open(FileName:=wbb)
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\comp-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub
You can use On Error Resume Next to ignore any error:
Const d As String = "C:\"
wba = "c.xlsm"
On Error Resume Next
Set wBook = Workbooks(wba)
On Error Goto 0
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(d & wba) 'join string d & wba
End If
This will check to see if you have the file open.
Option Explicit
Function InputOpenChecker(InputFilePath) As Boolean
Dim WB As Workbook
Dim StrFileName As String
Dim GetFileName As String
Dim IsFileOpen As Boolean
InputOpenChecker = False
'Set Full path and name of file to check if already opened.
GetFileName = Dir(InputFilePath)
StrFileName = InputFilePath & GetFileName
IsFileOpen = False
For Each WB In Application.Workbooks
If WB.Name = GetFileName Then
IsFileOpen = True
Exit For
End If
Next WB
If you dont have it open, check to see if someone else does.
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open StrFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
'Set the FileLocked Boolean value to true
FileLocked = True
Err.Clear
End If
And one reason for your error could be the inclusion of "FileName:=" in the Workbooks.Open. Try;
Set wbkA = Workbooks.Open(wba)
Set wbkB = Workbooks.Open(wbb)
Fixed my code and reposting with corrections for clarity.
Note I moved to C:\temp since writing to root C:\ folder should not be used because many work computers have root folder locked for security as my colleague just found out!
Sub RunCompare_WS9() 'compare two WKbooks, all sheets write diff to text file
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wbook1 As Workbook
Dim wbook2 As Workbook
wba = "C:\test\c.xlsm"
wbb = "C:\test\d.xlsm"
On Error Resume Next
Set wbook1 = Workbooks(wba)
On Error GoTo 0
If wbook1 Is Nothing Then
Set wbkA = Workbooks.Open(wba)
End If
On Error Resume Next
Set wbook2 = Workbooks(wbb)
On Error GoTo 0
If wbook2 Is Nothing Then
Set wbkB = Workbooks.Open(wbb)
End If
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\Test\comp2-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub