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
Related
Currently i am new on studying VBA for reporting and im still learning from it. moving on, may i ask a help on this one? :), my scenario is this.
i have data on 20 workbooks (POLY, BAYO, PROPO, TIPAS, CITRO....etc) with sheet name (Sheet1)
i have a single workbook for summary with many sheets, its sheet name is based on 20 workbook file name but not in alphabetical order. (Sheet name = CITRO, BAYO, PROPO, POLY, TIPAS....etc)
i want to copy the data on each workbook and paste it to their respective sheet name based on file name and specific cell ("B2:F2")
is it doable?
here's the code im trying to work on, the problem is, it is creating its own sheet instead of pasting it to my desire sheet.
Private Sub CommandButton1_Click()
Dim SourceBook As Workbook
Dim CurrentBook As Workbook
application.screenupdating = false
Set CurrentBook = ThisWorkbook
Set SourceBook = Workbooks.Open("C:\CITRO.xlsx")
SourceBook.Sheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Sheets("CITRO").Range("R2:V2")
Set SourceBook = Workbooks.Open("C:\BAYO.xlsx")
SourceBook.Sheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Sheets("BAYO").Range("R2:V2")
Set SourceBook = Workbooks.Open("C:\PROPO.xlsx")
SourceBook.Sheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Sheets("PROPO").Range("R2:V2")
MsgBox "Completed"
Application.Workbooks("CITRO").Close
Application.Workbooks("BAYO").Close
Application.Workbooks("PROPO").Close
'SourceBook.Close
'Set SourceBook = Nothing
'Set CurrentBook = Nothing
'ThisWorkbook.Activate
'Application.Worksheets("Summary").Activate
'Application.Worksheets("Summary").Range("B2:F2").Select
End Sub
You need to close the SourceBook before opening a new one with SourceBook.Close SaveChanges:=False
Private Sub CommandButton1_Click()
Dim SourceBook As Workbook
Dim CurrentBook As Workbook
Application.ScreenUpdating = False 'don't forget to activate it in the end
Set CurrentBook = ThisWorkbook
Set SourceBook = Workbooks.Open("C:\CITRO.xlsx")
SourceBook.Worksheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Worksheets("CITRO").Range("R2:V2")
SourceBook.Close SaveChanges:=False
Set SourceBook = Workbooks.Open("C:\BAYO.xlsx")
SourceBook.Worksheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Worksheets("BAYO").Range("R2:V2")
SourceBook.Close SaveChanges:=False
Set SourceBook = Workbooks.Open("C:\PROPO.xlsx")
SourceBook.Worksheets("Sheet1").Range("B2:F2").Copy Destination:=CurrentBook.Worksheets("PROPO").Range("R2:V2")
SourceBook.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox "Completed"
End Sub
Alternatively you can use a procedure to shorten it:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False 'don't forget to activate it in the end
CopyIntoThisWorkbook "C:\CITRO.xlsx", "CITRO"
CopyIntoThisWorkbook "C:\BAYO.xlsx", "BAYO"
CopyIntoThisWorkbook "C:\PROPO.xlsx", "PROPO"
Application.ScreenUpdating = True
MsgBox "Completed"
End Sub
Private Sub CopyIntoThisWorkbook(ByVal SourceFileName As String, ByVal DestinationSheetName As Range)
Dim SourceBook As Workbook
Set SourceBook = Workbooks.Open(SourceFileName)
SourceBook.Worksheets("Sheet1").Range("B2:F2").Copy Destination:=ThisWorkbook.Worksheets(DestinationSheetName).Range("R2:V2")
SourceBook.Close SaveChanges:=False
End Sub
And if the sheet name CITRO is always the filename CITRO.xlsx then you can even use an array with a loop:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False 'don't forget to activate it in the end
Dim SheetNameList() As Variant
SheetNameList = Array("CITRO", "BAYO", "PROPO") 'easily extendable
Dim SheetName As Variant
For Each SheetName In SheetNameList
CopyIntoThisWorkbook SheetName
Next SheetName
Application.ScreenUpdating = True
MsgBox "Completed"
End Sub
Private Sub CopyIntoThisWorkbook(ByVal DestinationSheetName As String)
Dim SourceBook As Workbook
Set SourceBook = Workbooks.Open("C:\" & DestinationSheetName & ".xlsx")
SourceBook.Worksheets("Sheet1").Range("B2:F2").Copy Destination:=ThisWorkbook.Worksheets(DestinationSheetName).Range("R2:V2")
SourceBook.Close SaveChanges:=False
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
My macro is going through a folder and picking each Excel file and deleting the first tab which is named some_Accounts and then copy pasting data to the master workbook where the worksheet names match.
Getting the following error Method 'Name' of object '_Worksheet' on the following line of code
Set wsDst = wbDst.Worksheets(wsSrc.Name)
I made sure that the worksheet names are equal.
Sub ProjectMacro()
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim lLastRow As Long
Dim LC As Long
Dim s As Worksheet, t As String
Dim i As Long, K As Long
K = Sheets.Count
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wbDst = ThisWorkbook
MyPath = "C:\Users\Adam\Desktop\some files\"
strFilename = Dir(MyPath & "*.xls*", vbNormal)
Do While strFilename <> ""
Set wbSrc = Workbooks.Open(MyPath & strFilename)
'loop through each worksheet in the source file
For Each wsSrc In wbSrc.Worksheets
'Find the corresponding worksheet in the destination with the same
name as the source
For i = K To 1 Step -1
t = Sheets(i).Name
If t = "some_Accounts" Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
End If
Next i
Set wsDst = wbDst.Worksheets(wsSrc.Name)
On Error GoTo 0
If wsDst.Name = wsSrc.Name Then
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
wsSrc.UsedRange.Copy
wsDst.Range("A" & lLastRow).PasteSpecial xlPasteValues
End If
Next wsSrc
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Right now, you are looping through all the Worksheets in wbSrc. When wsSrc is the "some_Accounts" sheet, right after you've deleted it within For i = K to 1... End For, it no longer exists, and thus wsSrc has no Name and will throw an error later on. If you're deleting a sheet, do so before you loop through all the sheets in a workbook.
But since you are closing wbSrc without saving changes, I assume that you don't really need to delete that sheet; you can just skip it as you're looping.
That would look something like this:
For Each wsSrc In wbSrc.Worksheets
If wsSrc.Name <> "some_Accounts" Then
'... copy and pasting code here
End If
Next wsSrc
Note that you can incorporate a WorksheetExists function into your code to make sure that there is a matching sheet in wbDst. That's already been provided in another answer.
Try to put this in your code to see if the worksheet exists:
If worksheetExists(wbDst, wsDst.Name) = true then
MsgBox "Exists!"
else
MsgBox "Does not exist!"
end if
Public Function worksheetExists(ByVal wb As Workbook, ByVal sheetNameStr As String) As Boolean
On Error Resume Next
worksheetExists = (wb.Worksheets(sheetNameStr).Name <> "")
Err.Clear: On Error GoTo 0
End Function
I have written some VBA code to see if a sheet exists and if it does deletes it and then resumes another module of code. For some reason the code I have below does not do anything and I can't figure out why.
Sub delete()
Dim ws As Worksheet
If worksheetexists("Export Worksheet") Then
Set ws = Worksheets("Export Worksheet")
Application.DisplayAlerts = False
ws.delete
Call GetData
Else
Call GetData
End If
End Sub
Public Function worksheetexists(sheetname As String, Optional wrkbk As Workbook) As Boolean
Dim wrksht As Worksheet
If wrkbk Is Nothing Then
Set wrkbk = ActiveWorkbook
End If
On Error Resume Next
Set wrksht = wrkbk.Worksheets(sheetname)
worksheetexists = (Err.Number = 0)
Set wrksht = Nothing
On Error GoTo 0
End Function
I updated your code slightly:
Sub delete()
Dim ws As Worksheet
If worksheetexists("Export Worksheet") Then
Set ws = Worksheets("Export Worksheet")
Application.DisplayAlerts = False
ws.delete
Call GetData("pass")
Else
Call GetData("fail")
End If
End Sub
and used this for GetData():
Sub GetData(s)
MsgBox s
End Sub
and it worked perfectly for both the pass and fail cases. Check the spelling of the worksheet name............................especially the number of spaces.
#BriannaCates, the function bellow works for me, maybe works for you.
Public Function deleteWorksheet(sheet As String, Optional work As Workbook) As Boolean
Dim ws As Worksheet
Dim deleted As Boolean
If work Is Nothing Then
Set work = ThisWorkbook
End If
deleted = False
For Each ws In work.Worksheets
If ws.Name = sheet Then
ws.Delete
deleted = True
Exit For
End If
Next
deleteWorksheet = deleted
End Function
I make a macro to open many files and do some operations like copy and paste in final file.
But I want when there is no file to skip the piece of code connected with this file:
'create variables'
FinalFile = "order.xls"
Obj1 = "order-obj1.xls"
Obj1Range = "E11"
......
Windows(Obj1).Activate
Range(MyRange).Select
Selection.Copy
Windows(FinalFile).Activate
Range(Obj1Range).Select
ActiveSheet.Paste
Windows(Obj1).Activate
ActiveWindow.Close
Windows(Obj2).Activate
Range(MyRange).Select
Selection.Copy
Windows(FinalFile).Activate
Range(Obj2Range).Select
ActiveSheet.Paste
Windows(Obj2).Activate
ActiveWindow.Close
If I can't open some file I recieve run time error 9. So my question is how to skip the code for Obj1 and proceed to Obj2?
I hope you can understand me...
Use the commmand Dir() to check whether the file exists.
e.g.
If Dir(Obj1) <> "" Then
Windows(Obj1).Activate
Range(MyRange).Select
Selection.Copy
Windows(FinalFile).Activate
Range(Obj1Range).Select
ActiveSheet.Paste
Windows(Obj1).Activate
ActiveWindow.Close
End If
Also, you probably want to put this code into a function so as not to repeat it, but that is another question.
UNTESTED
Here is how I would do it. Without using .SELECT/.ACTIVATE
Dim destwb As Workbook
Sub Sample()
Dim FinalFile As String
Dim Obj1 As String, Obj2 As String
Dim MyRange As String, Obj1Range As String, Obj1Rang2 As String
Dim wb As Workbook
'~~> Change as applicable
FinalFile = "order.xls"
Obj1 = "order-obj1.xls"
Obj2 = "order-obj2.xls"
Obj1Range = "E11"
Obj2Range = "E12"
MyRange = "A1"
Set destwb = Workbooks(FinalFile)
On Error Resume Next
Set wb = Workbooks(Obj1)
On Error GoTo 0
If Not wb Is Nothing Then
CopyRange wb, MyRange, Obj1Range
DoEvents
Set wb = Nothing
End If
On Error Resume Next
Set wb = Workbooks(Obj2)
On Error GoTo 0
If Not wb Is Nothing Then
CopyRange wb, MyRange, Obj2Range
DoEvents
Set wb = Nothing
End If
End Sub
Sub CopyRange(w As Workbook, r1 As String, r2 As String)
On Error GoTo Whoa
Dim ws As Worksheet, rng As Range
Set ws = w.Sheets(1)
Set rng = ws.Range(r1)
r1.Copy destwb.Sheets("Sheet1").Range(r2)
DoEvents
wb.Close savechanges:=False
Exit Sub
Whoa:
MsgBox Err.Description
End Sub