Please help me to to change the below code. Need to select the renaming cell through InputBox
Thanks
Sub RenWSs()
Dim WS As Worksheet
Dim shtName
Dim newName As String
Dim i As Integer
For Each WS In Worksheets
With WS
If Trim(.Range("c14")) <> "" Then
shtName = Split(Trim(.Range("c14")), " ")
newName = shtName(0)
On Error GoTo ws_name_error
.Name = newName
GoTo done
repeat:
.Name = newName & i
GoTo done
ws_name_error:
i = i + 1
Resume repeat
End If
End With
On Error GoTo 0
done:
Next
End Sub
There are a few ways you can use the InputBox to access Cell C4.
One is by selecting a String in the InputBox , see code below:
Dim RngStr As String
RngStr = Application.InputBox(prompt:="Select the Cell for the new Sheet's name", Type:=2)
If Trim(.Range(RngStr)) <> "" Then
Another, is by selecting a Range in the InputBox, see code below:
Dim rng As Range
Set rng = Application.InputBox(prompt:="Select the Cell for the new Sheet's name", Type:=8)
If Trim(rng) <> "" Then
Full Code
Option Explicit
Sub RenWSs()
Dim WS As Worksheet
Dim shtName
Dim newName As String
Dim i As Integer
Dim RngStr As String
RngStr = Application.InputBox(prompt:="Select the Range for the new Sheet's name", Type:=2)
For Each WS In Worksheets
With WS
If Trim(.Range(RngStr)) <> "" Then
shtName = Split(Trim(.Range(RngStr)), " ")
newName = shtName(0)
On Error GoTo ws_name_error
.Name = newName
GoTo done
repeat:
.Name = newName & i
GoTo done
ws_name_error:
i = i + 1
Resume repeat
End If
End With
On Error GoTo 0
done:
Next
End Sub
To read more about InputBox functionality: https://msdn.microsoft.com/en-us/library/office/ff839468.aspx
Related
I'm trying to add a new excel for each time a button is clicked, since the sheet is named after the date. However, I get an error that says "Cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook refernced by Visual basic."
Dim szTodayDate As String
szTodayDate = Format(Date, "mm.dd")
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = szTodayDate
What I want is to create a new worksheet that will be named mm.dd.i. While i refers to the number of time I create a new worksheet using the button. Sorry, I'm a VBA newbie.
Thank you for the answers. Gary's Student Made the most efficient one. Solved.
How about:
Sub sjvyv()
Dim szTodayDate As String
szTodayDate = Format(Date, "mm.dd")
Dim ws As Worksheet, i As Long
ReDim N(1 To Sheets.Count)
i = 1
For Each ws In Sheets
If Left(ws.Name, 5) = szTodayDate Then
N(i) = Mid(wsname, 6)
i = i + 1
End If
Next ws
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = szTodayDate & "." & i
End Sub
Here is a snippet that creates a new name for the sheet, that is available:
Sub AddSheet()
Dim TodayDate As String
Dim i As Integer
TodayDate = Format(Date, "mm.dd")
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
i = 1
Do While Not SheetNameAvailable(TodayDate & "." & i)
i = i + 1
Loop
ws.Name = TodayDate & "." & i
End Sub
Function SheetNameAvailable(SheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Err.Clear
Set ws = ThisWorkbook.Worksheets(SheetName)
SheetNameAvailable = (Err.Number <> 0)
On Error GoTo 0
End Function
On Error Resume Next
Set tempWS = Sheets(szTodayDate)
ws.Name = szTodayDate & IIf(tempWS Is Nothing, "", GetSheetCount(szTodayDate))
Set tempWS = Nothing
On Error GoTo 0
Function GetSheetCount(dateToTest) As Integer
Dim i As Integer
i = 1
For Each sh In ThisWorkbook.Sheets
If sh.Name Like dateToTest & "*" Then
i = i + 1
End If
Next
GetSheetCount = i
End Function
ws.Name = szTodayDate & ThisWorkbook.Sheets.Count + 1
Just append the count of sheets (+1) to the end.
I get a
Type Mismatch Error "13"
with the below code. Can anyone assist with where I'm going wrong with my VBA syntax and use of variables.
If Application.WorksheetFuntion.CountIf(Target, r.Value) > 1 Then
I've tried the matchFoundIndex code method to no success...Likely due to incorrect VBA syntax.
The intent of the CountIf line is to look for duplicates in column A. The rest of the code loops through files and worksheets copying the file name, worksheet name, and cell C1 for further analysis. I am a novice at coding and I'm sure there may be Dimmed variables that I'm not using, other formatting, and errors that I have not found yet. Any Help would be appreciative.
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
End If
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
If you want to check for Duplicates in a Range, you can use a Dictionary object.
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
For Each r In Target
If Trim(r.Value) <> "" Then
If Not Dict.exists(r.Value) Then ' not found in dictionary >> add Key
Dict.Add r.Value, r.Value
FindDuplicates = False
Else ' found in Dictionary >> Exit
FindDuplicates = True
Exit For
nd If
End If
Next r
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
I was having a similar experience using CountIF and passing it a range. In my case I was using:
i = Application.WorksheetFunction.CountIf(ws.UsedRange, r.Value)
which was giving me a Type Mismatch error. I had seen other people having success with the first parameter wrapped in Range() so after a few tries I found out that this would work:
i = Application.WorksheetFunction.CountIf(Range(ws.UsedRange.Address), r.Value)
So, I suggest that you change your code to this and see if it works:
If Application.WorksheetFuntion.CountIf(Range(Target.Address), r.Value) > 1 Then
I've written the following code which iterates though my worksheets of my main workbook, checks for a conditional, and then if that conditional is satisfied it copies the active worksheet into a new workbook and saves it. However, I would like to just append the worksheet to the other notebook.
Sub Archive_Sheets()
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Dim SrchRng As Range, cel As Range
Set SrchRng = ws.Range("C9:C108")
Dim bought_amt As Integer
Dim called_amt As Integer
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If InStr(1, cel.Value, "BOUGHT") > 0 Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If InStr(1, cel.Value, "CALLED") > 0 Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
ws.Range("A1").Value = "DONE"
Module8.CopySheet
Exit For
'ws.Delete
End If
Next
End Sub
Sub CopySheet()
Application.DisplayAlerts = False
Dim wb_name_arr() As String
pName = ActiveWorkbook.Path
wbName = ActiveWorkbook.Name ' the file name of the currently active file
shtName = ActiveSheet.Name ' the name of the currently selected worksheet
wb_name_arr() = Split(wbName, ".")
Application.ScreenUpdating = False
ActiveSheet.Select
ActiveSheet.Copy
' NEED TO CHANGE THIS LINE ********************
ActiveSheet.SaveAs Filename:=pName + "\" + wb_name_arr(0) + " archived.xlsx"
'****************************
Application.ScreenUpdating = True
End Sub
The code above will overwrite the new workbook I'm saving to so it's only the most recent sheet. I will already have this workbook created, so if I can append active worksheets to it that would be ideal. I already tried
ActiveSheet.Copy After:=Workbook(pName + "\" + wb_name_arr(0) + " archived.xlsx")
and
ActiveSheet.Copy Before:=Workbooks.Open(pName + "\" + wb_name_arr(0) + " archived.xlsx").Sheets(0)
with no luck.
These line are pseudo-codes. The general idea is Implicit None. Try to explicitly reference to workbooks and sheets instead of activating them. Which is also faster.
Try to avoid using ActiveSheet in your code. Simply try something like this:
Set mySht = ActiveSheet 'This should be set at the beginning of your code
Then whenever you have that Sheet (i.e. ActiveSheet) in your code, use oSht instead.
So, you need to open the Workbook to be able to work on it. Similarly, you can assign a name to different workbooks like this:
Set myWbk = ActiveWorkbook
'Or
Set oWbk = Workbooks("Output.xlsx")
What #A.S.H proposed then works for you like this:
oFile = "Path/to/the/File/" & wb_name_arr(0) & " archived.xlsx"
Set oWbk = Workbooks.Open(oFile)
mySht.Copy Before:=Workbooks(oWbk).sheets(1)
Private Sub that()
Dim aRR As Variant
aRR = ThisWorkbook.Sheets("Sheet1").UsedRange
Dim colC As Long
Dim rowC As Long
colC = ThisWorkbook.Sheets("Sheet1").UsedRange.Columns.Count
rowC = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
ThisWorkbook.Sheets("Sheet2").Range(ThisWorkbook.Sheets("Sheet2").Cells(1, 1), ThisWorkbook.Sheets("Sheet2").Cells(rowC, colC)).Value2 = aRR
End Sub
Try edited code (I've edited both Subs to make them shorter, and also faster as there is no need to use Select and Activate).
Explanation inside the code as comments.
Option Explicit
Sub Archive_Sheets()
Dim SrchRng As Range, cel As Range
Dim bought_amt As Long
Dim called_amt As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
With ws
Set SrchRng = .Range("C9:C108")
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If cel.Value Like "BOUGHT*" Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If cel.Value Like "CALLED*" Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
.Range("A1").Value = "DONE"
CopySheet .Name ' <-- call the function and send the current ws sheet's name
Exit For
End If
End With
Next
End Sub
'==================================================================
Sub CopySheet(wsName As String)
Application.DisplayAlerts = False
Dim wb_name_arr() As String
Dim wb As Workbook
Dim pName As String, wbName As String
pName = ActiveWorkbook.Path
wb_name_arr() = Split(wbName, ".")
Application.ScreenUpdating = False
On Error Resume Next
Set wb = Workbooks(wb_name_arr(0) & " archived.xlsx") ' try to set wb if it's already open
On Error GoTo 0
If wb Is Nothing Then ' <-- wb is Nothing, means it's still close, open it
Set wb = Workbooks.Open(Filename:=pName & "\" & wb_name_arr(0) & " archived.xlsx")
End If
' === Copy the sheet to "archived" file one before tha last sheet ===
Worksheets(wsName).Copy before:=wb.Sheets(wb.Sheets.Count)
Application.ScreenUpdating = True
End Sub
Full code that solves problem.
Sub Archive_Sheets()
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Dim SrchRng As Range, cel As Range
Set SrchRng = ws.Range("C9:C108")
Dim bought_amt As Integer
Dim called_amt As Integer
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If InStr(1, cel.Value, "BOUGHT") > 0 Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If InStr(1, cel.Value, "CALLED") > 0 Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
If called_amt <> 0 Then
ws.Range("A1").Value = "DONE"
Module8.CopySheet
'ws.Delete
End If
End If
Next
End Sub
Sub CopySheet()
Application.DisplayAlerts = False
Dim wb_name_arr() As String
pName = ActiveWorkbook.Path
wbName = ActiveWorkbook.Name ' the file name of the currently active file
shtName = ActiveSheet.Name ' the name of the currently selected worksheet
wb_name_arr() = Split(wbName, ".")
Set mySht = ActiveSheet 'This should be set at the beginning of your code
Set myWbk = ActiveWorkbook
oFile = pName & wb_name_arr(0) & " archived.xlsx"
Set oWbk = Workbooks.Open("path_to_file")
mySht.Copy after:=oWbk.Sheets(oWbk.Sheets.Count)
oWbk.Save
End Sub
Try something like this (to make it simple for the moment, I insert the sheet at beginning):
ActiveSheet.Copy Before:=Workbooks(wb_name_arr(0) & " archived.xlsx").sheets(1)
This works if the destination WB was already open. You may want to open the WB if it is not open yet. Use the following sub to create or open the destination WB:
Sub archiveSheet(ws as Worksheet)
Dim destName As String
destName = left(ThisWorkbook.name, InStrRev(ThisWorkbook.name, ".") - 1) & " archived.xlsx"
Application.DisplayAlerts = False: Application.ScreenUpdating = False
On Error Resume Next
Dim destWB As Workbook: Set destWB = Workbooks(destName)
If destWB Is Nothing Then Set destWB = Workbooks.Open(ThisWorkbook.path + "\" & destName)
If destWB Is Nothing Then
Set destWB = Workbooks.Add
destWB.SaveAs ThisWorkbook.path & "\" & destName
End If
If destWB Is Nothing Then
msgBox "could not open or create " & destName
Else
ws.Copy After:=destWB.Sheets(destWB.Sheets.count)
End If
Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub
Call it from the main routine Archive_Sheets like this:
archiveSheet ws
This is my code for copying a sheet to new sheet.
When I ran the program with breakpoint on Workbooks.Open(path) it was working correctly but when I ran without the breakpoint it simply opened the workbook without creating any sheet.
I have tried my best to rectify the error but I couldn't get the desired result.
Sub CopyCat()
Dim ws As Worksheet
Dim no As Integer
Set ws1 = ActiveSheet
Dim path As String
temp_name = InputBox("Enter the Sheet No to be Created", "Enter the Value")
For Loop1 = 1 To ws1.UsedRange.Rows.Count
path = Application.ActiveWorkbook.path & "\" & Application.WorksheetFunction.Trim(Trim(ws1.Cells(Loop1, 1).Value)) & " " & ws1.Cells(Loop1, 2).Value & ".xlsx"
Set wb1 = Workbooks.Open(path)
'ListBox1.AddItem wb.Name
temp_name = "Sheet" & temp_name
'error1 = CheckSheet(wb1, temp_name)
'If (error1 <> True) Then
ws1.Cells(4, 1).Value = "Created" & CStr(Loop1)
Set ws = wb1.Worksheets(Sheets.Count)
ws.Copy After:=wb1.Sheets(Sheets.Count)
Set ws = ActiveSheet
ws.Name = temp_name
'Call PageSetting
wb1.Close SaveChanges:=True
ws1.Cells(4, 1).Value = "Created Done" & CStr(Loop1)
'Else
'wb1.Close SaveChanges:=True
'End If
Next Loop1
End Sub
Function CheckSheet(ByVal wb As Workbook, ByVal sSheetName As String) As Boolean
Dim oSheet As Excel.Worksheet
Dim bReturn As Boolean
For Each oSheet In wb.Sheets
If oSheet.Name = sSheetName Then
bReturn = True
Exit For
End If
Next oSheet
CheckSheet = bReturn
End Function
This question is a bit vague, so i assumed a few things based on the code you provided.
You want to copy a worksheet from a workbook that runs the macro to another excel file.
All file names are listed in the source worksheet, column A - let's call it "Interface" worksheet.
You will need to add reference to Microsoft Scripting Runtime in your project for the FileSystemObject to work.
Code below isnt wery well written or optimised, yet it works.
Sub CopySht(NamesRange As Range, NameOfSheetToCopy As String)
Dim fso As FileSystemObject, oFile As File, fPath As String, fNamesArr() As Variant, fFolder As Folder
Set fso = New FileSystemObject
Dim InputWb As Workbook, InterfaceWs As Worksheet
Set InputWb = ThisWorkbook
Set InterfaceWs = InputWb.Worksheets("Interface")
Dim SheetToCopy As Worksheet
Set SheetToCopy = InputWb.Worksheets(NameOfSheetToCopy)
Set NamesRange = InterfaceWs.Range(NamesRange.Address)
fNamesArr() = NamesRange.Value
fPath = InputWb.path
Set fFolder = fso.GetFolder(fPath)
Dim i As Integer
For Each oFile In fFolder.Files
For i = LBound(fNamesArr) To UBound(fNamesArr)
If oFile.Name = fNamesArr(i, 1) & ".xls" Or oFile.Name = fNamesArr(i, 1) & ".xlsx" Then
On Error Resume Next
If Not (Workbooks(oFile.Name) Is Nothing) Then
Workbooks(oFile.Name).Close SaveChanges:=False
End If
Workbooks.Open (oFile.path)
If Not (CheckSheet(Workbooks(oFile.Name), SheetToCopy.Name)) Then
SheetToCopy.Copy After:=Workbooks(oFile.Name).Sheets(1)
Workbooks(oFile.Name).Close SaveChanges:=True
End If
If Not (Workbooks(oFile.Name) Is Nothing) Then
Workbooks(oFile.Name).Close SaveChanges:=False
End If
End If
Next i
Next oFile
End Sub
Function CheckSheet(ByVal wb As Workbook, ByVal sSheetName As String) As Boolean
Dim oSheet As Excel.Worksheet
Dim bReturn As Boolean
For Each oSheet In wb.Sheets
If oSheet.Name = sSheetName Then
bReturn = True
Exit For
End If
Next oSheet
CheckSheet = bReturn
End Function
It doesnt matter if you pass NamesRange as qualified or unqualified range object, as shown below
Sub Wrapper()
CopySht Range("A1:A6"), "CopyMe"
'CopySht ThisWorkbook.Worksheets("Interface").Range("A1:A6"), "CopyMe"
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