I had a requirement which is in excel macro. Here is the scenario :
I have 2 workbooks, Say A and B
Workbook "A" contains, sheet 1, sheet2 and sheet3, Workbook "B" contains sheet4
Now i need to compare Workbook "B" with Workbook A. If a sheet exist in Workbook "A" which is not in Workbook "B" (Here Sheet1, Sheet2, Sheet3) then i need to add these 3 sheets to Workbook "B"
So finally, B workbook should contain : Sheet 1, sheet 2, sheet 3 and sheet 4.
Tried below code but its not working.
Set act = ThisWorkbook
path = Sheet1.TextBox1.Text
Set owb = Workbooks.Open(Filename:=path)
For Each ws In ThisWorkbook.Worksheets
a = ws.Name
For Each ws1 In owb.Worksheets
If ws1.Name = a Then
MsgBox "Found"
Else
Set wsnew = owb.Sheets.Add
wsnew.Name = a
End If
Next ws1
Next ws
Rather than check each worksheet you could try and set a reference to it - if the reference is set then the sheet exists, if it throws an error then it doesn't exist.
I'd use a separate function to return TRUE/FALSE on the sheet existing - one of the few times that I'd use On Error Resume Next to ignore any errors.
Public Sub CopySheets()
Dim wrkBk As Workbook
Dim wrkSht As Worksheet
Dim wrkShtNew As Worksheet
Set wrkBk = Workbooks("Book2")
For Each wrkSht In ThisWorkbook.Worksheets
If Not WorkSheetExists(wrkSht.Name, wrkBk) Then
Set wrkShtNew = wrkBk.Worksheets.Add
wrkShtNew.Name = wrkSht.Name
Else
MsgBox wrkSht.Name & " exists.", vbOKOnly + vbInformation
End If
Next wrkSht
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 = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = wrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
Related
Ok what i want to do is make a macro that makes a new workbook with 5 tabs from a list in my excel.
I got the new workbook part, I got the (named) tabs part, but i'm stuck at the combination due to lack of knowledge.
Sub CreateForm()
Workbooks.Add
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("I6:I12")
With wBk
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
End Sub
It almost works, it makes a new workbook with extra tabs, but it is one too many(due to with creation it having one already), and they are not named.
Bonus Question: It would be awesome if I also could copy a tab(named "Results") from this workbook to the end of the new workbook, but this is just extra.
You can use this code.
I read the new worksheet names to an array.
The number of sheets in a new workbook can vary - as the user can configure this. Therefore I first delete all sheets except of the first one, then add then new sheets - and in the end delete the first one (which is left from the first deletion round)
Sub createNewWorkbookWithSheets()
Dim arrNewNames As Variant
arrNewNames = Application.Transpose(ActiveSheet.Range("I6:I12").Value)
Dim wbNew As Workbook
Set wbNew = Application.Workbooks.Add
Dim i As Long, ws As Worksheet
With wbNew
'delete all but the first worksheet - one has to be left
Application.DisplayAlerts = False
For i = 2 To .Worksheets.Count
.Worksheets(i).Delete
Next
Application.DisplayAlerts = True
'add new worksheet
For i = LBound(arrNewNames) To UBound(arrNewNames)
Set ws = .Worksheets.Add(, .Worksheets(.Worksheets.Count))
ws.Name = arrNewNames(i)
Next
'delete first ws
Application.DisplayAlerts = False
.Worksheets(1).Delete ' the left one from the first deletion round
Application.DisplayAlerts = True
End With
'copy result sheet from this workbook
Set ws = ThisWorkbook.Worksheets("Result")
ws.Copy , wbNew.Worksheets(wbNew.Worksheets.Count)
End Sub
You are adding a workbook, once that workbook has been created it becomes the active workbook.
If you want to use activeworkbook and activesheet to set the sheet name range, you could to do this before adding the new workbook.
Once you have run the code, you can delete the first sheet.
I think in this sample, you don't need activeworkbook because you are using activesheet
BTW I6:I12 would be 7 items not 5.
It need to be in chronological order.
Something like this.
Sub CreateForm()
Dim xRg As Range,rng as range
Dim wSh As Worksheet
Dim wBk As Workbook,bk as workbook
Set wBk = ActiveWorkbook
Set wSh = ActiveSheet
Set rng= wsh.range("I6:I12")
set bk = workbooks.add
For Each xRg In rng
With bk
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
End Sub
(a) wSh is set to the active sheet of the new created workbook and that is empty, therefore xRg.Value is always empty. This explains why your sheets are not renamed. Set it to the sheet holding the sheet names, eg
Set wSh = ThisWorkbook.Sheets(1)
(b) When you create a new Workbook, you will have (depending on your Excel settings) at least 1 worksheet. In your loop, you create a new sheet for every iteration, leaving the original sheets untouched. This explains why you have one sheet more than you expect.
Dim newSheetCount As Long
For Each xRg In wSh.Range("I6:I12")
With wBk
newSheetCount = newSheetCount + 1
' Add a new sheet if needed.
if .Sheets.Count < newSheetCount Then .Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
(c) Copying a sheet is easy, just use the Worksheet.Copy method:
ThisWorkbork.Sheets("Result").Copy After:=.Sheets(.Sheets.Count)
I need help with one aspect of my VBA code. I have a Master worksheet that houses data on all of my customers. I currently have code that looks at Column B (Customer Name Column) and creates new worksheets/tabs for each unique customer. I then want to cut and paste every row from my Master worksheet into individual respective worksheets based on the customer name. I've included a picture of my Master worksheet. I've also included the code I'm currently working with is below, it creates the new tabs but won't copy and paste.
Sub CreateWSandCopyPaste()
Application.ScreenUpdating = False
Dim cell As Range
Dim thisSheetName As String
AWS = ActiveSheet.Name
'Creates new worksheet/tab for every unique value in Column B (Customer Code Column)
For Each cell In Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
If (cell.Value <> "") Then
If (IsSheetExist(cell.Value) = False) Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = cell.Value
End If
End If
Next
'Copy and paste value A:U if the value in column B matches the tab name
Dim ws As Worksheet
For Each ws In Sheets
If ActiveSheet.Range("B2").Value = ws.Name Then
ActiveSheet.Range("A:U").CurrentRegion.Copy Destination:=ws.Range("A:U" & Rows.Count).End(x1Up)
End If
Next
Application.ScreenUpdating = True
End Sub
Private Function IsSheetExist(ByVal newSheetName As String)
Dim ws As Worksheet
For Each ws In Worksheets
If (ws.Name = newSheetName) Then
IsSheetExist = True
Exit Function
End If
Next
' ---
IsSheetExist = False
End Function
Master Worksheet - Customer Column
You can do it like this:
Sub CreateWSandCopyPaste()
Dim cell As Range, v
Dim thisSheetName As String, wb As Workbook, ws As Worksheet
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set wb = ws.Parent
'Creates new worksheet/tab for every unique value in Column B (Customer Code Column)
For Each cell In ws.Range(ws.Range("B2"), ws.Range("B" & Rows.Count).End(xlUp)).Cells
v = cell.Value
If Len(v) > 0 Then cell.EntireRow.Range("A1:U1").Copy _
GetSheet(v, wb).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next
Application.ScreenUpdating = True
End Sub
'Return a named sheet in wb (or create if doesn't exist)
Private Function GetSheet(ByVal SheetName As String, wb As Workbook)
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Worksheets(SheetName)
On Error GoTo 0
If ws Is Nothing Then
Set ws = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
ws.Name = SheetName
End If
Set GetSheet = ws
End Function
I modified code from Copy worksheet into different workbook replacing current data.
If I deselect range or I have selected different cell than A1, code falls into 1004 error.
Sub TG_update()
Dim wb1 As Workbook, wb2 As Workbook, ws1Format As Worksheet, ws2Format As Worksheet, ws3Format As Worksheet, ws4Format As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("[add your path.xlsx]")
Set ws1Format = wb1.Sheets("SheetA1")
Set ws2Format = wb2.Sheets("SheetB1")
Set ws3Format = wb1.Sheets("SheetA2")
Set ws4Format = wb2.Sheets("SheetB2")
'' Copy the cells of the "Format" worksheet.
ws2Format.Cells.Copy
'' Paste cells to the sheet "Format".
wb1.Sheets("SheetA1").Paste
ws4Format.Cells.Copy
wb1.Sheets("SheetB1").Paste
wb2.Close False 'remove false if you want to be asked if the workbook shall be saved.
wb1.Sheets("Store").Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Date successfully updated"
End Sub
Please try this code. Instead of copying and pasting millions of blank cells this code copies the worksheet from the source and pastes it to the workbook with the code. If the action is successful the old sheet is deleted. The final report alerts about errors if sheets weren't found.
Sub TG_update()
' 016
Dim Wb As Workbook ' ThisWorkbook
Dim WbS As Workbook ' Source
Dim Ffn As String ' Full FileName
Dim Ws As Worksheet
Dim TabName() As String
Dim i As Integer ' TabName index
Dim n As Integer ' tab counter
Set Wb = ThisWorkbook
' specify the workbook to be copied from: Full path and name
Ffn = "F:\AWK PC\Drive E (Archive)\PVT Archive\Class 1\1-2018 (Jan 2020)\TXL 180719 Z Distance.xlsm"
' enumerate the sheet names in CSV format (sheets must exist in Wb)
TabName = Split("SheetA1,SheetB1", ",")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set WbS = Workbooks.Open(Ffn)
For i = 0 To UBound(TabName)
On Error Resume Next ' suppress error if worksheet isn't found
WbS.Worksheets(TabName(i)).Copy After:=Wb.Worksheets(Wb.Worksheets.Count)
If Err.Number = 0 Then
n = n + 1
End If
Next i
WbS.Close SaveChanges:=False
On Error GoTo 0
For i = 0 To UBound(TabName)
For Each Ws In Wb.Worksheets
If InStr(Ws.Name, TabName(i) & " (") = 1 Then
Wb.Worksheets(TabName(i)).Delete
Ws.Name = TabName(i)
End If
Next Ws
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox n & " of " & i & " worksheets were successfully updated.", _
vbInformation, "Action report"
End Sub
Creative names like Wb1, Wb2, Ws1, Ws2, SheetA1, SheetA2 represent the punishment imaginative programmers inflict on those who come after them to correct their hastily concocted code. Give your VBA project a better reputation by bestowing names on your two worksheets that permit their identification.
I have a master workbook, which houses a group of 15 worksheets that house data for summary pivot tables and whatnot. Every week this master workbook gets updated with a daily report that has those 15 worksheets, but also around 20 other ones. I am just trying to get a script together to identify if they exist, and if so, to move that daily data to the master workbooks worksheet (only move data if daily wb worksheet exists in master workbook).
Here is a very general shell of what I'm trying to achieve, but I'm not well versed in determining the logic if a sheet exists, so my blnFound variable is obviously misplaced. I hope this shows a rough outline of what I'm trying to achieve. Any help is greatly appreciated!
Option Explicit
Sub Update_New_Data()
Const BasePath As String = "C:\\User\Data..."
Dim wbMaster As Workbook: Set wbMaster = ThisWorkbook
Dim wbNewData As Workbook: Set wbNewData = Workbooks.Open(BasePath & "\03.01.20.xlsx")
Dim wsMaster As Sheet
Dim blnFound As Boolean
'places all sheet names into array
With wbNewData
Dim varWsName As Variant
Dim i As Long
Dim ws As Worksheet
ReDim varWsName(1 To wbNewData.Worksheets.Count - 2)
For Each ws In wbNewData.Worksheets
Select Case ws.Name
Case "Inputs", "Data --->>>"
Case Else
i = i + 1
varWsName(i) = ws.Name
End Select
Next
End With
'if wbNewData sheet name is found in wbMaster
'then locate it and place wbNewData data into that sheet
With wbMaster
For Each wsMaster In wbMaster.Sheets
With wsMaster
If .Name = varWsName(i) Then
blnFound = True
wbNewData(Worksheets(i)).UsedRange.Copy Destination:=wbMaster(Worksheets(i)).Range("A1")
Else: blnFound = False
End If
End With
Next
End With
End Sub
To check if something exists you can use a Dictionary Object
Option Explicit
Sub Update_New_Data()
Const BasePath As String = "C:\\User\Data..."
Dim wbMaster As Workbook, wbNewData As Workbook
Set wbMaster = ThisWorkbook
Set wbNewData = Workbooks.Open(BasePath & "\03.01.20.xlsx", , False) ' read only
Dim ws As Worksheet, sKey As String, rng As Range, msg As String
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
'places all master sheet names into dictionary
For Each ws In wbMaster.Sheets
If ws.Name = "inputs" Or ws.Name = "Data --->>>" Then
' skip
Else
dict.Add CStr(ws.Name), ws.Index
Debug.Print "Added to dict", ws.Index, ws.Name
End If
Next
' if wbNewData sheet name is found in wbMaster
' then locate it and place wbNewData data into that sheet
For Each ws In wbNewData.Sheets
sKey = CStr(ws.Name)
If dict.exists(sKey) Then
' clear master
wbMaster.Sheets(dict(sKey)).cells.clear
Set rng = ws.UsedRange
rng.Copy wbMaster.Sheets(dict(sKey)).Range("A1")
msg = msg & vbCr & ws.Name
Else
Debug.Print "Not found in master", ws.Index, ws.Name
End If
Next
wbNewData.Close
' result
If Len(msg) > 0 Then
MsgBox "Sheets copied were " & msg, vbInformation
Else
MsgBox "No sheets copied", vbExclamation
End If
End Sub
I would like to write a vba code that will not allow to add duplicate sheets with same name. I have a code that is assigned to button on the sheet that is used to change the name of the active sheet.
Sheets are copied from "Main" sheet and hence all the sheets will have button to rename the sheet based on the value selected in the cells A8 and K11 (Both these cells have drop down list with values).
My concern is when user selects the button to rename the sheet, it should look for all the sheets in workbook and display a message if duplicate sheet exists else it should rename the sheet. I am confused in passing values, I am still a starter. Please help
Sub RenameCurrentSheet()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim ws As Worksheet
ThisWorkbook.Unprotect Password:="xyz"
For x = 1 To worksh
If ActiveSheet.Name = "MainSheet" Then
MsgBox "You Cannot Change Name of This Sheet!!!"
Exit For
Else
ActiveSheet.Name = Range("A8").Value & "-" & Range("K11").Value
Exit For
End If
Next x
Application.DisplayAlerts = True
ThisWorkbook.Protect Password:="xyz"
End Sub
To iterate through the worksheets use code like this:
dim wks as Worksheet
for I = 1 to Application.Worksheets.Count
set wks = Application.Worksheets(i)
Debug.Print wks.Name
.... whatever else you want do do
next i
set wks = Nothing ' When done with the object
Just try and reference the worksheet to see if it exists - if it throws an error, then the sheet doesn't exist.
Your code fails as you're always looking at the activesheet, but never changing which sheet is active.
Public Sub CopyAndRenameSheet()
Dim wrkSht As Worksheet
Dim sNewName As String
With ThisWorkbook
'Copy the template to the end of the workbook.
.Worksheets("MainSheet").Copy After:=.Sheets(.Sheets.Count)
'Set reference to last sheet in workbook (the one you've just copied).
Set wrkSht = .Worksheets(.Sheets.Count)
With wrkSht
'Get the new name from the ranges.
sNewName = .Range("A8") & "-" & .Range("K11")
If WorkSheetExists(sNewName) Then
MsgBox "You Cannot Change Name of This Sheet!!!", vbOKOnly + vbCritical
'Do something with the sheet, otherwise you'll be left with a
'sheet called something like "MainSheet (1)".
Application.DisplayAlerts = False
wrkSht.Delete
Application.DisplayAlerts = True
Else
.Unprotect Password:="xyz"
wrkSht.Name = sNewName
.Protect Password:="xyz"
End If
End With
End With
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 = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
This code copies the name to be assigned from the template instead of the ActiveSheet. If you create the name from the active sheet and make sure that the name meets Excel requirements for sheet names, this code ought to work.