Visual Basic, Check if a sheet exists in another workbook - vba

I'm really new to Visual Basic and I don't know any python either, I'm trying to write code that is able to check if a worksheet exists in a workbook...
Sub sheetexist()
If Len(Dir(("C:\My Data\Performance Spreadsheets\[ABCD - Performance.xls]Jun 14"))) Then
MsgBox "Sheet exist"
Else
MsgBox "Sheet does not exist"
End If
End Sub
ABCD does have the sheet for Jun 14 however the code only returns "Sheet does not exist", is there another way to check for worksheets in other workbooks?

I think you're mis-using the Dir function.
The easiest way to check if a sheet exists is with error-handling.
Function SheetExists(wbPath as String, shName as String)
Dim wb as Workbook
Dim val
'Assumes the workbook is NOT open
Set wb = Workbooks.Open(wbPath)
On Error Resume Next
val = wb.Worksheets(shName).Range("A1").Value
SheetExists = (Err = 0)
'Close the workbook
wb.Close
End Function
Call the function like this from a worksheet cell:
=SheetExists("C:\My Data\Performance Spreadsheets\ABCD - Performance.xls", "Jun 14")
Or from VBA like:
Debug.Print SheetExists("C:\My Data\Performance Spreadsheets\ABCD - Performance.xls", "Jun 14")
Without opening the workbook, you could use the code here.
This will raise an error if any part of the formula can't evaluate (e.g., if you pass the name of a non-existent sheet, a bad file path, etc., Error 2023:
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "\" Then wbPath = wbPath & "\"
If Dir(wbPath & "\" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
Call it:
Sub Test()
Dim path As String
Dim filename As String
Dim sheetName As String
Dim cellAddress As String
path = "c:\users\you\desktop"
filename = "file.xlsx"
sheetName = "Jun 14"
cellAddress = "A1"
Dim v As Variant 'MUST BE VARIANT SO IT CAN CONTAIN AN ERROR VALUE
v = GetInfoFromClosedFile(path, filename, sheetName, cellAddress)
If IsError(v) Then MsgBox "Sheet or filename doesn't exist!"
End Sub

Related

Set Prompted Excel Spreadsheet to new Workbook Object

I'm trying to assign a new excel worksheet that is being prompt to open as a new Workbook Object. I'm trying the below code, however it's not working
Option Explicit
Sub MoveGeneratedReport()
Dim newWbReport As Workbook
Dim MonthlyComplianceReport As Workbook
Set MonthlyComplianceReport = SelectWorkbook
End Sub
Private Function SelectWorkbook() As Workbook
Dim strFileToOpen As String
strFileToOpen = Application.GetOpenFilename(Title:="Select Compliancy Report for export", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strFileToOpen <> False Then '<---- Error Ocuring here
Workbooks.Open Filename:=strFileToOpen
End If
End Function
I'm receiving the
"Type Mismatch"
error, however if I just run the function SelectWorkbook() it works fine and opens the document.
My end goal here is to open the document and then assign it to a Workbook object. Any suggestions to fix this error?
EDIT:
I should clarify my question here too... How can I assign this newly opened Workbook via the prompt to a Workbook object so that the rest of my code can work with it?
EDIT 2:
This seems to be working really well
Option Explicit
Sub MoveGeneratedReport()
Dim newWbReport As Workbook
Dim MonthlyComplianceReport As Workbook
Set MonthlyComplianceReport = SelectWorkbook
Debug.Print MonthlyComplianceReport.Name
End Sub
Private Function SelectWorkbook() As Workbook
Dim strFileToOpen As String
strFileToOpen = Application.GetOpenFilename(Title:="Select Compliancy Report for export", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strFileToOpen <> "" Then
On Error GoTo ErrHandle
Set SelectWorkbook = Workbooks.Open(Filename:=strFileToOpen)
End If
Exit Function
ErrHandle:
If Err.Number <> 1004 Then
MsgBox "Error " & Str(Err.Number) & Chr(13) & _
"Error Line: " & Erl & Chr(13) & Chr(13) & _
Err.Description
End If
End Function
GetOpenFilename returns a String so it wont ever be true or false. Test for an empty string instead:
If strFileToOpen <> "" Then
Edit:
To set the workbook object change it to this:
Private Function SelectWorkbook() As Workbook
Dim strFileToOpen As String
strFileToOpen = Application.GetOpenFilename(Title:="Select Compliancy Report for export", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strFileToOpen <> "" Then
Set SelectWorkbook = Workbooks.Open(Filename:=strFileToOpen)
End If
End Function

Loop cells in VBA.

I am trying to make my code better, as every beginner I have problem to make it more "systematic", I would like your advice on how to do it.
I open few workbook, so now my macro looks like this.
Sub OpenWorkbooks()
workbooks.Open Filename :="C/.../file1.xlsx"
workbooks.Open Filename :="C/.../file2.xlsx"
workbooks.Open Filename :="C/.../file3.xlsx"
.
.
End sub
Its quite ugly, I would like to have each path in a cell. Let say from A1 to A3 and to loop this cell to open the workbooks. Any idea how I could do this?
In an other part of my code, nicely found on the web, I have the same problem. I would like to be able to enter my paths somewhere in my spreadsheet and then to loop it from there instead of entering manually one by one...
This is the second part of the code, quite clueless how I should do this...
Sub GetNumber()
Dim wWbPath As String, WbName As String
Dim WsName As String, CellRef As String
Dim Ret As String
Workbooks("file1").Close SaveChanges:=True
wbPath = "C:/etc...."
WbName = "file1.xlsx"
WsName = "Sheet1"
CellRef = "AD30"
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
Worksheets("Sheet1").Range("A1") = ExecuteExcel4Macro(arg)
'Then I need to do all again for the second workbook etc....
End sub
Any idea is welcome,
Thank you!
To answer the first part of your question:
Sub OpenWorkbooks()
For i = 1 to 3 ' Loop 3 times
Workbooks.Open Filename:=Sheet1.cells(i,1).value
'Cells refers to Row and column, so i will iterate three times while keeping the column the same.
Next i
End sub
If you don't know how many loops you will want to make, you could use the following to check the Last Row with data and loop until you reach it:
Sub OpenWorkbooks()
LastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 to LastRow ' Loop as many times until the last row with data
Workbooks.Open Filename:=Sheet1.cells(i,1).value
'Cells refers to Row and column, so i will iterate three times while keeping the column the same.
Next i
End sub
For the second part of your code you could do something like:
Sub GetNumber()
Dim wWbPath As String, WbName As String
Dim WsName As String, CellRef As String
Dim Ret As String
For i = 1 to 5 'Change this to however many files you will be using
FileName = Sheet1.cells(i,1).value
Workbooks(FileName).Close SaveChanges:=True
wbPath = "C:/etc...."
WbName = FileName & ".xlsx"
WsName = "Sheet1"
CellRef = "AD30"
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
Worksheets("Sheet1").Range("A" & i) = ExecuteExcel4Macro(arg)
'Then I need to do all again for the second workbook etc....
Next i
End sub
I had to figure out how do something similar recently. Try this ...
Dim i As Long
Dim SelectedFiles As Variant
SelectedFiles = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", _
Title:="Select files", MultiSelect:=True)
If IsArray(SelectedFiles) Then
For i = LBound(SelectedFiles) To UBound(SelectedFiles)
Set wbkToOpen = Workbooks.Open(Filename:=SelectedFiles(i), corruptload:=xlRepairFile)
Debug.Print wbkToOpen.Name
Debug.Print SelectedFiles(i)
wbkToOpen.Close savechanges:=False
Next
End If

Combining macros in Excel

I'm trying to combine/nest 3 different functions in Excel VBE: open, loop, and click. I have them written out separately, but am unsure of how to combine them. I've tried the "call macro" function but got a compile error returned to me.
The goal is to open a bunch of files within a certain folder and click on the URL in all of them (the URL will not always be the same, so I need a click function that targets any unknown URL within a sheet).
Open macro:
Sub openMyfile()
Dim Source As String
Dim StrFile As String
Source = "/users/kmogilevsky/Desktop/IC_new/"
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Do While Len(StrFile) > 0
Workbooks.Open Filename:=Source & StrFile
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Loop
End Sub
Loop macro:
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
Set MySource = MyObj.GetFolder("/users/kmogilevsky/Desktop/IC_new/")
For Each file In MySource.Files
If InStr(file.Name, "test") > 0 Then
End If
Next file
End Sub
Click macro (this needs some work):
Private Sub CommandButton1_Click()
Call NewSub
End Sub
Sub ReadWorkbooksInCurrentFolder()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim MyPath As String
Dim strFilename As String
'Stop annoying popups while macro is running
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'When working with many open workbooks its good to explicitly reference all workbooks, makes sure your code works and easier to read, understand and remember which workbook is which.
Set wbDst = ThisWorkbook
srcSheetName = "Data"
dstSheetName = "Results"
'I want to loop through all .xlsx files in the folder
MyPath = ThisWorkbook.Path
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)
If Len(strFilename) = 0 Then
MsgBox "No workbooks found ending in .xlsx in current folder"
Exit Sub
End If
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Call CollectData(wbDst, wbSrc, dstSheetName, srcSheetName)
wbSrc.Close
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub CollectData(ByRef wbDst as Workbook, ByRef wbSrc as Workbook, dstSheetName as String, srcSheetName as String)
'Copy cell A1 contents in source workbook to destination workbook cell A1
wbDst.Sheets(dstSheetName).Range("A1") = wbSrc.Sheets(srcSheetName).Range("A1")
End Sub
Please edit the subroutine CollectData() so that it suits your needs, i.e. performs the click / url open. (I am not familiar with opening urls from excel, but I loop through workbooks often)
This code will open all Excel files in the IC_New folder on the desktop.
It will then look at each sheet and follow any hyperlinks that are on the sheet.
Sub Open_ClickHyperlinks()
Dim sPath As String
Dim vFiles As Variant
Dim vFile As Variant
Dim wrkBk As Workbook
Dim wrkSht As Worksheet
Dim HLink As Hyperlink
sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & _
"IC_New" & Application.PathSeparator
'Return all files that have an extension starting with xls.
vFiles = EnumerateFiles(sPath, "xls*")
'Loop through each file.
For Each vFile In vFiles
'Open the file
Set wrkBk = Workbooks.Open(Filename:=vFile, UpdateLinks:=False)
With wrkBk
'Loop through each worksheet in the file.
For Each wrkSht In .Worksheets
'Loop through each hyperlink on the worksheet.
For Each HLink In wrkSht.Hyperlinks
HLink.Follow
Next HLink
Next wrkSht
.Close SaveChanges:=False
End With
Next vFile
End Sub
'Get all files in the specified folder, default to include all subfolders as well.
Public Function EnumerateFiles(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function

Excel Sheet Name Error

I'm using a VBA code to cycle through excel files in a directory and pull information from one worksheet and paste into a newly created worksheet. I'm also naming my new worksheets (in my destination file) by the name in one of the cells in the source file.
My code works for the first loop but fails/stops in the second loop (VBA points to an error in the Dest.Sheets.Add(After:=Dest.Sheets(Dest.Sheets.Count)).Name = Sheetname line. I need to loop through 75 of these files and I'm unsure of what's going on because it works correctly for the first file.
Thanks so much for the help!
Sub AddSummaryTables()
Dim Spath, Filename, Sheetname As String
Dim Source, Dest As Workbook
Dim WS As Worksheet
Set Dest = ThisWorkbook
Spath = InputBox("Enter File Source Path") & "\"
Filename = Dir(Spath & "*.xls*")
Do While Filename <> ""
Set Source = Workbooks.Open(Spath & Filename)
Sheetname = Source.Sheets("Summary").Range("B2").Text
MsgBox Sheetname
Dest.Sheets.Add(After:=Dest.Sheets(Dest.Sheets.Count)).Name = Sheetname
Source.Sheets("Summary").Range("A1:R150").Copy
Dest.Worksheets(Sheetname).Range("A1").PasteSpecial xlPasteValues
Dest.Worksheets(Sheetname).Range("A1").PasteSpecial xlPasteFormats
Dest.Worksheets(Sheetname).Range("A1:R150").WrapText = False
Dest.Worksheets(Sheetname).Rows.AutoFit
Dest.Worksheets(Sheetname).Columns.AutoFit
Source.Close SaveChanges:=False
Dest.Save
Filename = Dir()
Loop
End Sub
following Comintern's and Wyatt's suggestion you could try like follows
Option Explicit
Sub AddSummaryTables()
Dim sPath As String, fileName As String
Dim sourceWb As Workbook, destWb As Workbook
Dim sourceWs As Worksheet, destWs As Worksheet
Set destWb = ThisWorkbook
sPath = InputBox("Enter File Source Path") & "\"
fileName = Dir(sPath & "*.xls*")
Do While fileName <> ""
Set sourceWb = Workbooks.Open(sPath & fileName)
Set sourceWs = GetWorksheet(sourceWb, "Summary")
If Not sourceWs Is Nothing Then
Set destWs = SetWorksheet(destWb, sourceWs.Range("B2").Text)
sourceWs.Range("A1:R150").Copy
With destWs
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").PasteSpecial xlPasteFormats
.UsedRange.WrapText = False
.Rows.AutoFit
.Columns.AutoFit
End With
sourceWb.Close SaveChanges:=False
destWb.Save
End If
fileName = Dir()
Loop
End Sub
Function GetWorksheet(wb As Workbook, sheetName As String) As Worksheet
On Error Resume Next
Set GetWorksheet = wb.Worksheets(sheetName)
On Error GoTo 0
End Function
Function SetWorksheet(wb As Workbook, sheetName As String) As Worksheet
Dim i As Integer
Do While Not GetWorksheet(wb, sheetName & IIf(i = 0, "", "-" & i)) Is Nothing
i = i + 1
Loop
With wb
.Worksheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = sheetName & IIf(i = 0, "", "-" & Format(i, "000"))
Set SetWorksheet = .ActiveSheet
End With
End Function
where you make sure that
any opened workbook has a "Summary" worksheet
you name worksheets in your destination workbook such as not to have duplicates: if you happen to deal with say three worksheets named "Sheet5" then your destination workbook will have added worksheets "Sheet5", "Sheet5-001" and "Sheet5-002".
You're issue may be that when you are adding the sheet from the second workbook, it has the same name as the sheet from the first workbook. You could check if the sheet exists and add a number to it. The post below might help.
Test or check if sheet exists

Opening workbooks via hyperlink and then using Hyperlink name as workbook reference

I'm trying to take the hyperlink workbook name and put it into my code.
Sub Workbook()
Dim vbaname as string
Dim WBMaster As Workbook, WBSource As Workbook
Dim WSMaster As Worksheet, WSSource As Worksheet
Range("b7").Hyperlinks(1).Follow
'returns the hyperlink text "Vba Source test"
VbaName = """" & Range("B7").Text & """"
Set WBSource = Workbooks(VbaName)
I get a subscript out of range bug. Is there another way to do this. I just want to be able to put the hyperlink text into that bracket.
If you Debug.Print your VbaName it actually holds the value of B7 but the active window ( the followed one from hyperlink ). If you want to get the name of the workbook from the hyperlink, youre working in, then use this code
Sub GetWorkbookName()
MsgBox "the name of the workbook in the hyperlink is: " & vbCrLf & _
getWorkbookName(Range("B7").Text)
End Sub
Private Function getWorkbookName(hyperLink As String) As String
Dim i&
For i = 1 To Len(hyperLink)
If StrComp(Left(Right(hyperLink, i), 1), "\", vbTextCompare) = 0 Then
getWorkbookName = Right(hyperLink, i - 1)
Exit For
End If
Next i
End Function
On the other hand, I think you are trying to open the workbook from the hyperlink and assign a reference to it. The way you go about it it's not the right approach. I think you may want to consider doing it this way:
Sub Workbook()
Dim wbFromHyperLink As String
Dim WBSource As Workbook
MsgBox "the name of the workbook in the hyperlink is: " & vbCrLf & _
getWorkbookName(Range("B7").Text)
wbFromHyperLink = getWorkbookName(Range("B7").Text)
'Range("b7").Hyperlinks(1).Follow
Set WBSource = Workbooks.Open(Range("B7").Text)
' do not forget to close and free the object
' WBSource.Saved = True
' WBSource.Close
' Set WBSource = Nothing
End Sub
Private Function getWorkbookName(hyperLink As String) As String
Dim i&
For i = 1 To Len(hyperLink)
If StrComp(Left(Right(hyperLink, i), 1), "\", vbTextCompare) = 0 Then
getWorkbookName = Right(hyperLink, i - 1)
Exit For
End If
Next i
End Function