I'm simply trying to find the workbook beginning with D and containing the sheet "Bob".
This is my code, but it doesn't like wb.Name when I call the function. What am I supposed to put there so it works?
Sub View_Email()
'Select report workbook D*
For Each wb In Application.Workbooks
If wb1.Name Like "D*" And WorksheetExists("Bob", wb.Name) Then
Ct = Ct + 1
wb1.Activate
Set WB_rep = ActiveWorkbook
Exit For
End If
Next wb1
If Ct = 0 Then
MsgBox "Could not find D* file (report). Code will end."
Exit Sub
End If
'Copy Burn-Down chart from report
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
Thank you for your help. The following code is working now:
Sub View_Email()
Dim wb As Workbook
'Select report workbook D*
For Each wb In Application.Workbooks
If wb.Name Like "D*" And WorksheetExists("Bob", wb) Then
Ct = Ct + 1
wb.Activate
Set WB_rep = ActiveWorkbook
Exit For
End If
Next wb
If Ct = 0 Then
MsgBox "Could not find D* file (report). Code will end."
Exit Sub
End If
'Copy Burn-Down chart from report
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
Related
I have two error handlers to look for if two separate workbooks are open?
Sub ErrHandler()
wbsource_name=ThisWorkbook.Worksheets("Sheet1").Range("A1").Value
wbdest_name=ThisWorkbook.Worksheets("Sheet1").Range("B1").Value
On Error GoTo Here
Set wb_source=Workbooks(wbsource_name)
Here:
MsgBox "Open main file"
Exit Sub
'I want here to stop first err handler
'The next file to be opened(or looked if is open)
'So if first file is open, but second not. It again gives the first error handler message
On Error GoTo 0
On Error GoTo Here2
Set wb_destination=Workbooks(wbdest_name)
Here2:
MsgBox "Open UPO file"
I tried On error GoTo 0 to neutralize the first error handler.
I also tried On error Resume Next.
I prefer to push out a potentially error-generating action into a separate method (particularly that action is repeated in the main code).
Sub Tester()
Dim wbSrc As Workbook, wbDest As Workbook, wbsource_name As String, wbdest_name As String
wbsource_name = ThisWorkbook.Worksheets("Sheet1").Range("A1").Value
wbdest_name = ThisWorkbook.Worksheets("Sheet1").Range("B1").Value
Set wbSrc = GetOpenWorkbook(wbsource_name, "Workbook '" & wbsource_name & "' must be open")
If wbSrc Is Nothing Then Exit Sub
Set wbDest = GetOpenWorkbook(wbdest_name, "Workbook '" & wbdest_name & "' must be open")
If wbDest Is Nothing Then Exit Sub
End Sub
'Return an open workbook given its name, or Nothing if not found
' Optional message `msgMissing` to show if not found
Function GetOpenWorkbook(wbName As String, Optional msgMissing As String = "") As Workbook
On Error Resume Next
Set GetOpenWorkbook = Workbooks(wbName)
On Error GoTo 0
If GetOpenWorkbook Is Nothing And Len(msgMissing) > 0 Then
MsgBox msgMissing
End If
End Function
Create Workbook References
Option Explicit
Sub TestOpenWorkbooks()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim swbName As String: swbName = ws.Range("A1").Value
Dim dwbName As String: dwbName = ws.Range("B1").Value
On Error Resume Next
Dim swb As Workbook: Set swb = Workbooks(swbName)
On Error GoTo 0
If swb Is Nothing Then
MsgBox "Open main file."
Exit Sub
End If
On Error Resume Next
Dim dwb As Workbook: Set dwb = Workbooks(dwbName)
On Error GoTo 0
If dwb Is Nothing Then
MsgBox "Open UPO file."
Exit Sub
End If
MsgBox "Files open. Ready to continue."
End Sub
Sub TestOpenWorkbooksImproved()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim swbName As String: swbName = ws.Range("A1").Value
Dim dwbName As String: dwbName = ws.Range("B1").Value
Dim wbPath As String: wbPath = "C:\Test\"
' This will work either way: open or not open.
Dim swb As Workbook: Set swb = Workbooks.Open(wbPath & swbName)
Dim dwb As Workbook: Set dwb = Workbooks.Open(wbPath & dwbName)
MsgBox "Files open. Ready to continue."
End Sub
EDIT
Sub TestOpenWorkbooksFunction()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim swbName As String: swbName = ws.Range("A1").Value
Dim dwbName As String: dwbName = ws.Range("B1").Value
Dim swb As Workbook: Set swb = RefWorkbook(swbName)
If swb Is Nothing Then
MsgBox "Open main file."
Exit Sub
End If
Dim dwb As Workbook: Set dwb = RefWorkbook(dwbName)
If dwb Is Nothing Then
MsgBox "Open UPO file."
Exit Sub
End If
MsgBox "Files open. Ready to continue."
End Sub
Function RefWorkbook( _
ByVal WorkbookName As String) _
As Workbook
On Error Resume Next
Set RefWorkbook = Workbooks(WorkbookName)
On Error GoTo 0
End Function
Sub RefWorkbookTEST()
Dim wb As Workbook: Set wb = RefWorkbook("?")
If wb Is Nothing Then
Debug.Print "Nope"
Else
Debug.Print wb.Name
End If
End Sub
I wrote a code that is opening a window in which I can select a the excel workbook (#2) I want to copy and import the worksheet from.
The Code is then checking whether the wanted worksheet (named "Guidance") exists in the opened workbook (#2).If so it should be copied and pasted into the current workbook (#1).
After pasting the worksheet the workbook (#2) should be closed again.
So far the code does what I want it to do, as it opens the window and lets me select the wanted worksheet (named "Guidance") but I have the bug (not sure if the translation is correct)
"Runtime error '9': index out of range"
where the worksheet is supposed to be copied and pasted.
Any help on that would be very much appreciated! Thanks in advance.
Private Function SheetExists(sWSName As String, Optional InWorkbook As Workbook) As Boolean
If InWorkbook Is Nothing Then
Set InWorkbook = ThisWorkbook
End If
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(sWSName)
If Not ws Is Nothing Then SheetExists = True
On Error GoTo 0
End Function
Sub GuidanceImportieren()
Dim sImportFile As String, sFile As String
Dim sThisWB As Workbook
Dim vFilename As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sThisWB = ActiveWorkbook
sImportFile = Application.GetOpenFilename("Microsoft Excel Workbooks,
*xls; *xlsx; *xlsm")
If sImportFile = "False" Then
MsgBox ("No File Selected")
Exit Sub
Else
vFilename = Split(sImportFile, "|")
sFile = vFilename(UBound(vFilename))
Application.Workbooks.Open (sImportFile)
Set wbWB = Workbooks("sImportFile")
With wbWB
If SheetExists("Guidance") Then
Set wsSht = .Sheets("Guidance")
wsSht.Copy Before:=sThisWB.Sheets("Guidance")
Else
MsgBox ("No worksheet named Guidance")
End If
wbWB.Close SaveChanges:=False
End With
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The issue is here
Set wbWB = Worksheets("Guidance") '<-- this should be a workbook not a worksheet?
With wbWB '<-- this with is useless until …
If SheetExists("Guidance") Then
Set wsSht = .Sheets("Guidance") '<-- … until Sheets here starts with a dot
wsSht.Copy Before:=sThisWB.Sheets("Guidance") 'if the error is here then there is no sheet "Guidance" in sThisWB
Else
MsgBox ("No worksheet named Guidance")
End If
wbWB.Close SaveChanges:=False
End With
Also note that SheetExists("Guidance") does not check in a specific workbook (which may fail). I recommend to extend the function to:
Private Function SheetExists(WorksheetName As String, Optional InWorkbook As Workbook) As Boolean
If InWorkbook Is Nothing Then
Set InWorkbook = ThisWorkbook 'fallback if not set
End If
Dim ws As Worksheet
On Error Resume Next
Set ws = InWorkbook.Worksheets(WorksheetName)
SheetExists = Not ws Is Nothing
On Error Goto 0 'necessary because the Err.Number will not be cleared on End Function
End Function
So you can test if a worksheet exists in a specific workbook like
SheetExists("Guidance", sThisWB)
SheetExists("Guidance", wbWB)
Sub GuidanceImportieren()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sImportFile As String
sImportFile = Application.GetOpenFilename("Microsoft Excel Workbooks, *xls; *xlsx; *xlsm")
If sImportFile = False Then 'false should not be "false"
MsgBox "No File Selected"
Exit Sub
Else
Dim vFilename As Variant
vFilename = Split(sImportFile, "|")
Dim sFile As String
sFile = vFilename(UBound(vFilename))
Dim ImportWorkbook As Workbook
Set ImportWorkbook = Application.Workbooks.Open(sImportFile)
If SheetExists("Guidance", ImportWorkbook) Then
ImportWorkbook.Sheets("Guidance").Copy Before:=ThisWorkbook.Sheets("Guidance")
'you might need to change it into something like this:
Else
MsgBox "No worksheet named Guidance"
End If
ImportWorkbook.Close SaveChanges:=False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I want to search for an open file named "OTIF"[...].
When the macro finds the workbook, it should paste the file name into "sheet1" Cell A1 in another workbook (wb2).
Sub Filename()
Dim Wb1 As Workbook, wb2 As Workbook, wB As Workbook
For Each wB In Application.Workbooks
If Left(wB.Name, 4) = "OTIF" Then
Set Wb1 = wB
Exit For
End If
Next
If Not Wb1 Is Nothing Then
Set wb2 = ThisWorkbook
End If
With wb2.Sheets("AAA")
.Range("A1").Value = Dir(Wb1.FullName)
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "DONE!"
End Sub
I looked at your code and it can be simplified like below.
Sub Filename()
Dim wB As Workbook
For Each wB In Application.Workbooks
If Left(wB.Name, 4) = "OTIF" Then
ThisWorkbook.Sheets("AAA").Range("A1").Value = wB.FullName
Exit For
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "DONE!"
End Sub
What do you want to achieve with
Dir(Wb1.FullName)
That is the source of your problem. Just delete the Dir and the () and its running: .Range("A1").Value = Wb1.FullName
Full Edited code:
Option Explicit
Sub Filename()
Dim Wb1 As Workbook, wb2 As Workbook, wB As Workbook
Dim ws As Worksheet
Set wb2 = ThisWorkbook
On Error Resume Next
Set ws = wb2.Worksheets("AAA")
On Error GoTo 0
If ws Is Nothing Then ' make sure "AAA" sheet exists
MsgBox "AAA sheet does not exist, or has been renamed", vbCritical
Exit Sub
End If
For Each wB In Application.Workbooks
If Left(wB.Name, 4) = "OTIF" Then
' for DEBUG ONLY
ws.Range("A1").Value = wB.Sheets.Count
' 2nd Debug option
ws.Range("A1").Value = "Test"
' ws.Range("A1").Value = wB.Name
MsgBox "DONE!"
Exit For
End If
Next
End Sub
Sub delete()
Dim sh As Worksheet, wb As String, c As Range
wb = InputBox("work book name")
Set sh = Workbooks(wb).Sheets
For Each Sheet In sh
If IsEmpty(sh.UsedRange) Then
sh.delete
End If
Next
End Sub
I am unable to delete the empty sheets using above code.
The below code deletes all empty sheets in the currently opened workbook
try this instead
Sub delete()
Application.DisplayAlerts = False
Dim sh As Worksheet
For Each sh In Sheets
If IsEmpty(sh.UsedRange) Then sh.delete
Next
Application.DisplayAlerts = True
End Sub
if you want to specify the full path with the name use
Sub delete()
Dim wb As Workbook, s As String
s = InputBox("Full workbook path & name")
Dim fileExists As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
fileExists = fso.fileExists(s)
If fileExist Then
Set wb = Workbooks.Open(s)
For Each Sheet In sh
If IsEmpty(sh.UsedRange) Then
sh.delete
End If
Next
Else
MsgBox "File doesn't exist", vbCritical, "Error"
End If
End Sub
I have an existing worksheet "StudentSheet1" which I need to add as many times as a user needs.
For eg, if a user enters 3 in cell "A1", saves it and closes the workbook.
I want to have three sheets: "StudentSheet1" , "StudentSheet2" and "StudentSheet3" when the workbook is opened next time.
So I will have the Code in "Workbook_Open" event. I know how to insert new sheets, but cant insert this particular sheet "StudentSheet1" three times
Here is my code:
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets.Add(Type:=xlWorksheet, After:=Worksheets(1))
Application.ScreenUpdating = True
End Sub
EDIT
Sorry I misread the question, try this:
Private Sub Workbook_Open()
Dim iLoop As Integer
Dim wbTemp As Workbook
If Not Sheet1.Range("A1").value > 0 Then Exit Sub
Application.ScreenUpdating = False
Set wbTemp = Workbooks.Open(Filename:="//Ndrive/Student/Student.xlsm")
wbTemp.Sheets("StudentSheet1").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
wbTemp.Close
Set wbTemp = Nothing
With Sheet1.Range("A1")
For iLoop = 2 To .Value
Sheets("StudentSheet1").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = "StudentSheet" & iLoop
Next iLoop
.Value = 0
End With
Application.ScreenUpdating = True
End Sub
Why are you wanting to add sheets on the workbook open? If the user disables macros then no sheets will be added. As Tony mentioned, why not add the sheets when called by the user?
EDIT
As per #Sidd's comments, if you need to check if the sheet exists first use this function:
Function SheetExists(sName As String) As Boolean
On Error Resume Next
SheetExists = (Sheets(sName).Name = sName)
End Function
user793468, I would recommend a different approach. :)
wbTemp.Sheets("StudentSheet1").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
is not reliable. Please see this link.
EDIT: The above code will fail if the workbook has defined names. Otherwise it is absolutely reliable. Thanks to Reafidy for catching that.
I just noticed OP's comment about the shared drive. Adding amended code to incorporate OP's request.
Tried and Tested
Option Explicit
Const FilePath As String = "//Ndrive/Student/Student.xlsm"
Private Sub Workbook_Open()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim TempName As String, NewName As String
Dim ShtNo As Long, i As Long
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wb1 = ActiveWorkbook
Set ws1 = wb1.Sheets("Sheet1")
ShtNo = ws1.Range("A1")
If Not ShtNo > 0 Then Exit Sub
Set wb2 = Workbooks.Open(FilePath)
Set ws2 = wb2.Sheets("StudentSheet1")
For i = 1 To ShtNo
TempName = ActiveSheet.Name
NewName = "StudentSheet" & i
If Not SheetExists(NewName) Then
ws2.Copy After:=wb1.Sheets(Sheets.Count)
ActiveSheet.Name = NewName
End If
Next i
'~~> I leave this at your discretion.
ws1.Range("A1").ClearContents
LetsContinue:
Application.ScreenUpdating = True
On Error Resume Next
wb2.Close savechanges:=False
Set ws1 = Nothing
Set ws2 = Nothing
Set wb2 = Nothing
Set wb1 = Nothing
On Error GoTo 0
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
'~~> Function to check if sheet exists
Function SheetExists(wst As String) As Boolean
Dim oSheet As Worksheet
On Error Resume Next
Set oSheet = Sheets(wst)
On Error GoTo 0
If Not oSheet Is Nothing Then SheetExists = True
End Function