Updating my workbook - vba

I have created a Workbook that is used in various different computers.
Sometimes I add features to it and I would like to easily update it.
The idea is whenever I have a new version of it, I take it to a new computer, save in a temp file and copy the sheets where the data is stored.
Based on the answers I have edit my first draft to: (I didn't know that both workbooks needed to be opened at the same time)
Private Sub CommandButton1_Click()
Dim sh As Worksheet
Dim ws As Worksheet
Dim wb As Workbook
Dim wn As Workbook
Set wn = Workbooks("Reception")
Set wb = Workbooks("Reception2")
With wb
.Sheets("Pass").Range("A1") = "flh"
For Each ws In .Worksheets
Select Case .Name
Case "Formularios", "Coordenador", "LookupList", "Pass"
'Do nothing
Case Else
ws.Delete
End Select
Next ws
End With
With wn
For Each sh In .Worksheets
Select Case .Name
Case "Formularios", "Coordenador", "LookupList", "Pass"
'Do nothing
Case Else
sh.Copy After:=wb.Sheets(wb.Sheets.Count)
End Select
Next sh
End With
End Sub
Case at moment is not working and macro deletes every sheet no matter the name
Thank you all for the feedback

You can find the temp folder by using Environ("temp"), but from your code I'm not sure this is the folder you're using.
This code has a couple of functions to check if the workbook exists and is already open. One other bit of code I'd add is to disable any code in Reception.xlsm from firing when it's opened.
Public Sub MyProcedure()
Dim ws As Worksheet
Dim wb As Workbook
Dim wn As Workbook
Dim Rec1Path As String
Dim Rec2Path As String
Rec1Path = "c:\save\Reception.xlsm"
Rec2Path = "c:\temp\Reception2.xlsm"
'Open or set a reference to Reception.xlsm.
If WorkBookExists(Rec1Path) Then
If WorkBookIsOpen(Rec1Path) Then
'Don't need path for open workbook, just name.
'InStrRev finds last occurrence of "\" (same as InStr, but in Reverse).
Set wn = Workbooks(Mid(Rec1Path, InStrRev(Rec1Path, "\") + 1))
Else
Set wn = Workbooks.Open(Rec1Path)
End If
End If
'Open or set a reference to Reception2.xlsm.
If WorkBookExists(Rec2Path) Then
If WorkBookIsOpen(Rec2Path) Then
Set wb = Workbooks(Mid(Rec2Path, InStrRev(Rec2Path, "\") + 1))
Else
Set wb = Workbooks.Open(Rec2Path)
End If
End If
With wb
.Worksheets("Pass").Range("A1") = "flh"
For Each ws In .Worksheets
Select Case .Name
Case "Formularios", "Coordenador", "LookupList", "Pass"
'Do nothing
Case Else
'You don't really need the count of worksheets if you can guarantee
'you're not going to try and delete the last remaining sheet.
If .Worksheets.Count > 1 Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End Select
Next ws
End With
With wn
'Re-using the ws variable.
For Each ws In .Worksheets
Select Case .Name
Case "Formularios", "Coordenador", "LookupList", "Pass"
'Do nothing
Case Else
ws.Copy After:=wb.Sheets(wb.Sheets.Count)
End Select
Next ws
End With
End Sub
Public Function WorkBookExists(sPath As String) As Boolean
WorkBookExists = Dir(sPath) <> ""
End Function
Public Function WorkBookIsOpen(FullFilePath As String) As Boolean
Dim ff As Long
On Error Resume Next
ff = FreeFile()
Open FullFilePath For Input Lock Read As #ff
Close ff
WorkBookIsOpen = (Err.Number <> 0)
On Error GoTo 0
End Function

Is the workbook open when you try to 'SET' it? If not you will need to open it as such:
Dim wb As Workbook
Set wb = Workbooks.Open("c:\temp\Reception.xlsm")

With some more googling I was able to craft the code that I wanted in the end.
Here is the answer for the curious or for other people looking to do the same:
Private Sub CommandButton1_Click()
Dim sh As Worksheet
Dim ws As Worksheet
Dim LastRow As Long
Dim LastCol As Long
Dim j As Long
Dim Rng As Range
Dim wb As Workbook
Dim wn As Workbook
Set wn = Workbooks("Reception")
Set wb = Workbooks("Reception2")
With wb
.Sheets("Pass").Range("A1") = "flh"
For Each ws In .Worksheets
Select Case ws.Name
Case "Formularios"
'Do nothing
Case "Coordenador"
'Do nothing
Case "LookupList"
'Do nothing
Case "Pass"
'Do nothing
Case Else
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set Rng = .Range(.Cells(2, 1), .Cells(LastRow, LastCol))
Rng.ClearContents
End With
End Select
Next ws
End With
With wn
For Each sh In .Worksheets
Select Case sh.Name
Case "Formularios"
'Do nothing
Case "Coordenador"
'Do nothing
Case "LookupList"
'Do nothing
Case "Pass"
'Do nothing
Case Else
For j = 1 To wb.Sheets.Count
If sh.Name = wb.Worksheets(j).Name Then
On Error Resume Next
sh.Range("A:J").Copy wb.Worksheets(j).Range("A1")
End If
Next j
End Select
Next sh
End With
Application.CutCopyMode = False
End Sub
Thanks to #Darren Bartrup-Cook for the help.

Related

How to use worksheet names as variables in Excel VBA

I am trying to write a macro that will prompt the user to open 2 workbooks and then loop through the worksheets in the 2 books comparing their contents and highlighting any differences in yellow. Each piece seems to be working on its own, but I cannot figure out how to set the workbook names as global variables to be used between the functions in my sub. Any help would be appreciated! :)
Public strFile1 As String
Public strFile2 As String
Public wbSource1 As Workbook
Public wbSource2 As Workbook
Public I As Integer
Sub DifferenceCheckBetweenBooks()
Call openIt
Call WorksheetLoop
End Sub
Function openIt()
strFile1 = Application.GetOpenFilename
Workbooks.Open strFile1
Set wbSource1 = Workbooks.Open(strFile1)
strFile2 = Application.GetOpenFilename
Workbooks.Open strFile2
Set wbSource2 = Workbooks.Open(strFile2)
End Function
Function WorksheetLoop()
Dim WS_Count As Integer
WS_Count = Workbooks(wbSource1).Worksheets.Count
' Begin the loop.
For I = 1 To WS_Count
Call compareBooks
Next I
End Function
Function compareBooks()
Dim mycell As Range
'For each cell in worksheet that is not the same as compared worksheet, color it yellow
For Each mycell In Workbooks(wbSource1).Worksheets(I).UsedRange
If Not mycell.Value = Workbooks(wbSource2).Worksheets(I).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = vbYellow
Workbooks(wbSource2).Worksheets(I).Cells(mycell.Row, mycell.Column).Interior.Color = vbYellow
End If
Next
Workbooks(wbSource2).Worksheets(I).Select
End Function
I am getting the classic "subscript out of range error" which points to my wbSource1 variable as empty.
Don't do this
Workbooks.Open strFile1
Set wbSource1 = Workbooks.Open(strFile1)
you only need
Set wbSource1 = Workbooks.Open(strFile1)
And as SJR points out:
WS_Count = wbSource1.Worksheets.Count 'plus all other instances of this
You should really refactor your code to remove the globals and use parameters in your methods instead - that's a much safer approach.
Refactored to remove globals:
Sub DifferenceCheckBetweenBooks()
Dim wb1 As Workbook, wb2 As Workbook
Set wb1 = OpenIt("Choose first file")
If wb1 Is Nothing Then Exit Sub
Set wb2 = OpenIt("Choose second file")
If wb2 Is Nothing Then Exit Sub
CompareWorkbooks wb1, wb2
End Sub
Sub CompareWorkbooks(wb1 As Workbook, wb2 As Workbook)
Dim i As Long, sht1 As Worksheet, sht2 As Worksheet, c As Range, c2 As Range
For i = 1 To wb1.Worksheets.Count
Set sht1 = wb1.Worksheets(i)
Set sht2 = wb2.Worksheets(i)
For Each c In sht1.UsedRange.Cells
Set c2 = sht2.Range(c.Address)
If c.Value <> c2.Value Then
c.Interior.Color = vbYellow
c2.Interior.Color = vbYellow
End If
Next c
Next i
End Sub
Function OpenIt(msg As String) As Workbook
Dim strFile
strFile = Application.GetOpenFilename(Title:=msg)
If Len(strFile) > 0 Then Set OpenIt = Workbooks.Open(strFile)
End Function

Excel VBA - rename all worksheets from col of new names in another workbook

This question is vaguely similar to renaming multiple worksheets from list using VBA, but is too different to get the answer from that question.
I will regularly need to rename dozens of worksheets in various incoming workbooks.
I wish to rename all worksheets by first copying all the worksheet names into a secondWorkbook.sheets(1) colA, manually creating new names in ColB, and then run a second macro to update the names in the originalWorkbook.
I am stuck on the second macro, but will provide both macros below. If anyone has a shorter/better way of writing these macros, I am all eyes.
First macro - copy all worksheet names into a new workbook.sheet(1).colA. This works, and creates a new unsaved workbook with the tab names in ColA
Sub GrabAllTabNamesIntoTempWorkbookColA()
Dim tst, tmp, allTabNames As String
Dim i, cnt, cnt2 As Long
Dim wb, wbTmp As Workbook, xWs, ws1 As Worksheet
Dim arrOldNames, arrNewNames As Variant
ReDim arrOldNames(999)
cnt = 0
With ActiveWorkbook
For Each xWs In .Worksheets
If xWs.Visible = xlSheetVisible Then
arrOldNames(cnt) = xWs.Name
cnt = cnt + 1
End If
Next
End With
ReDim Preserve arrOldNames(cnt - 1)
cnt2 = 1
Set wbTmp = Workbooks.Add
Set ws1 = wbTmp.Sheets(1)
For i = 1 To cnt
ws1.Range("A" & i).Value = arrOldNames(i - 1)
Next
MsgBox "Done. Copied " & cnt & " tab names."
End Sub
Here is the macro I am stuck on. Both workbooks are open on screen, and I don't mind editing the macro to provide the workbook names. Unsure how to reference an unsaved workbook with a name like "Book4 - Microsoft Excel", so I have been saving it as Temp.xlsx and referencing it as namesWb. The workbook with the tabs to be renamed is referenced as targetWb
Sub RenameAllTabsFromColAInTempWorkbook()
Dim namesWb, targetWb As Workbook
Dim colA, colB As Variant
Set namesWb = Windows("Temp.xlsx")
Set targetWb = ActiveWorkbook
ReDim colA(999), colB(999)
cnt = 0
With namesWb
Sheets(1).Activate
For i = 1 To 999
If Range("A" & i).Value = "" Then Exit For
colA(i - 1) = Range("A" & i).Value
colB(i - 1) = Range("B" & i).Value
cnt = cnt + 1
Next
ReDim Preserve colA(cnt)
ReDim Preserve colB(cnt)
End With
For each oldname in colA()
'Stuck here...
Next
End Sub
I realize that I could again loop through the targetWb and, for each tabname, find the location of that tabname in ColA() and rename it with the same position name from tabB() - but I am wondering if there is a faster/better way to do this.
You can loop through active workbooks like this:
Sub t()
Dim mainWB As Workbook, tempWB As Workbook
Dim wb As Workbook
Set mainWB = ActiveWorkbook
For Each wb In Application.Workbooks
'Loops through the workbooks.
Debug.Print wb.Name
If wb.Name Like "Book*" Then
Set tempWB = wb
End If
Next wb
End Sub
Edit: Since you only have two open workbooks, you can shorten that:
Sub t()
Dim mainWB As Workbook, tempWB As Workbook
Dim wb As Workbook
Set mainWB = ActiveWorkbook ' MAKE SURE THIS IS CORRECT!! May need `ThisWorkbook` if the new temporary one becomes the active one.
For Each wb In Application.Workbooks
'Loops through the workbooks.
Debug.Print wb.Name
If wb.Name <> mainWB.Name And wb.Name <> "PERSONAL.XLSB" Then
Set tempWB = wb
' Now do whatever you need with the Temporary workbook.
End If
Next wb
End Sub
I've refactored both your Sub's to show a more robust method.
Dim all variables, with explicit types (some of yours were defaulting to Variant)
Record the Workbook being processed in the top of the Names list
Still processes the ActiveWorkbook
Save the Temp workbook into the same folder as ActiveWorkbook
Rename... now skips any missing new names
Detect missing OldNames (see comment in code, place any response you want there)
Detect failed Renames (eg could be invalid characters in the new names)
Sub GrabAllTabNamesIntoTempWorkbookColA()
Dim wbToRename As Workbook
Dim wbTmp As Workbook
Dim xWs As Worksheet
Dim ws1 As Worksheet
Dim arrOldNames As Variant
Dim arrNewNames As Variant
Dim cnt As Long
Set wbToRename = ActiveWorkbook
With wbToRename
' Size array based on number of sheets in workbook
ReDim arrOldNames(1 To .Worksheets.Count, 1 To 1)
cnt = 0
For Each xWs In .Worksheets
If xWs.Visible = xlSheetVisible Then
cnt = cnt + 1
arrOldNames(cnt, 1) = xWs.Name
End If
Next
End With
Set wbTmp = Workbooks.Add
Set ws1 = wbTmp.Sheets(1)
'Place data in sheet in one go
ws1.Cells(1, 1) = wbToRename.Name
ws1.Cells(2, 1).Resize(UBound(arrOldNames, 1), 1) = arrOldNames
MsgBox "Done. Copied " & cnt & " tab names."
'Save workbook
wbTmp.SaveAs Filename:=wbToRename.Path & "\Temp", FileFormat:=xlOpenXMLWorkbook
End Sub
Sub RenameAllTabsFromColAInTempWorkbook()
Dim namesWb As Workbook
Dim targetWb As Workbook
Dim wsNames As Worksheet
Dim ws As Worksheet
Dim NamesList As Variant
Dim cnt As Long
Dim i As Long
Set namesWb = Application.Workbooks("Temp.xlsx")
Set targetWb = Application.Workbooks(namesWb.Worksheets(1).Cells(1, 1).Value)
cnt = 0
Set wsNames = namesWb.Worksheets(1)
With wsNames
'Get Names into one variable, based on actual number of rows
NamesList = wsNames.Range(wsNames.Cells(2, 2), wsNames.Cells(wsNames.Rows.Count, 1).End(xlUp)).Value
For i = 1 To UBound(NamesList, 1)
' Check if the Name has been entered
If NamesList(i, 2) <> vbNullString Then
'Get reference to sheet by old name, and handle if sheet is missing
Set ws = Nothing
On Error Resume Next
Set ws = targetWb.Worksheets(NamesList(i, 1))
On Error GoTo 0
' Rename sheet
If Not ws Is Nothing Then
On Error Resume Next
ws.Name = NamesList(i, 2)
On Error GoTo 0
If ws.Name <> NamesList(i, 2) Then
' Rename failed! What now?
End If
Else
'Sheet Missing! What now?
End If
End If
Next
End With
End Sub

Deleting specific sheets and those which do not meet a criteria

I have a macro where I create a number of sheets that take their names from the values in column c, cell 7 onwards in a sheet called "Schedule". I am using the following code for that
Sub CreateDataSheets()
'Updateby Extendoffice 20161215
Dim xRg As Variant
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("C7", Range("C7").End(xlDown))
If Not IsError(xRg) Then
If xRg <> "" Then
If Not WorksheetExists((xRg)) Then
With wBk
.Sheets.Add after:=.Sheets(.Sheets.Count), Type:="L:\London\General\Reference & Tools\Software\BIM\IiA_Specifications\Excel\Uk Specification Template.xltx"
ActiveSheet.Name = xRg.Value
End With
End If
End If
End If
Next xRg
Application.ScreenUpdating = True
End Sub
Now I need another Macro where if I change or delete any of these values in Column C, I want to create new updated ones and delete all the sheets that are redundant. While doing this, I want to retain the sheets called Schedule, Home and CoverSheet. Below is the code I tried to write but that would not work.
Sub DeleteNewSheets()
Dim ws As Worksheet
Dim ArrayOne() As Variant
Dim wsName As Variant
Dim Matched As Boolean
Dim DirArray As Variant
DirArray = Range("C7:C11")
ArrayOne = Array("Home", "Schedule", "CoverSheet", DirArray.Value)
Application.DisplayAlerts = False
For Each ws In Sheets
Matched = False
For Each wsName In ArrayOne
If wsName = ws.Name Then
Matched = True
Exit For
End If
Next
If Not Matched Then
ws.Delete
End If
Next ws
Application.DisplayAlerts = True
End Sub
Would really appreciate any ideas...
DirArray is beeing created as a Variant and the position 4 of your Array ArrayOne is actually another array and not a string.
To fix it, initialize the ArrayOne just like this:
ArrayOne = Array("Home", "Schedule", "CoverSheet")
Dim Name As Variant
For Each Name In DirArray
If Name <> "" Then
ReDim Preserve ArrayOne(UBound(ArrayOne) + 1)
ArrayOne(UBound(ArrayOne)) = Name
End If
Next
It will also not consider empty values on the range you selected.
Consider changing your removing steps as on Sam's answer
Iterating over a changing set is often a bad idea. Do something like this instead
For i = Sheets.Count to 1 Step -1
If ....
Sheets(i).Delete
End If
Next i

Vlookup on external workbook VBA

I don't know how it isn't working.
I have my active workbook. I want to run macros from active sheet.
1. I want to add 2 more columnes with headers . - works
2. I want to open external file, which is base in my vloop. - works
3. I want to use vloop to find my variable from active sheet in external workbook and save result in my active sheet
Sub ImpFPQ()
Application.ScreenUpdating = False
On Error Resume Next
Dim Imp_Row As Integer
Dim Imp_Col As Integer
Dim Baza1 As Workbook
Dim Baza2 As Workbook
Dim wksheet As Worksheet
Dim plik As Variant
Set wksheet = ActiveWorkbook.ActiveSheet
'add columns with names
wksheet.Columns("A:B").Insert Shift:=xlToRight
wksheet.Columns("A").Cells(1, 1) = "KOD"
wksheet.Columns("B").Cells(1, 1) = "LICZNIK"
'open file
plik = Application.GetOpenFilename(Title:="Wybierz raport")
If plik = False Then Exit Sub
Workbooks.Open Filename:=plik
Set Baza1 = ThisWorkbook 'activesheet
Set Baza2 = Workbooks(plik) 'external workbook
Set lastel = Baza2.Range("F3", Range("F3").End(xlDown)).Select
Set lookFor = Baza1.Cells(2, 4) 'aktualny subsyst do znalezienia
Set srchRange = Baza2.Sheets(1).Range("A3:lastel")
Range("A2").Value = Application.VLookup(lookFor, srchRange, 6, False)
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
I have these columns, but rows dont have results. Can someone help me?
This should do the trick.
Sub ImpFPQ()
Application.ScreenUpdating = False
On Error Resume Next
Dim Imp_Row As Integer
Dim Imp_Col As Integer
Dim Baza1 As Workbook
Dim Baza2 As Workbook
Dim wksheet As Worksheet
Dim plik As Variant
Dim lastRow As Long
Dim lookfor As Variant
Dim srchRange As Range
Set wksheet = ActiveWorkbook.ActiveSheet
'add columns with names
wksheet.Columns("A:B").Insert Shift:=xlToRight
wksheet.Columns("A").Cells(1, 1) = "KOD"
wksheet.Columns("B").Cells(1, 1) = "LICZNIK"
'open file
plik = Application.GetOpenFilename(Title:="Wybierz raport")
If plik = False Then Exit Sub
Workbooks.Open Filename:=plik
Set Baza1 = ThisWorkbook 'activesheet
Set Baza2 = Workbooks.Open(plik) 'external workbook
With Baza2.Sheets(1)
lastRow = .Cells(.Rows.Count, 6).End(xlUp).Row
End With
lookfor = Baza1.Cells(2, 4) 'aktualny subsyst do znalezienia
Set srchRange = Baza2.Sheets(1).Range("A3:F" & lastRow)
Range("A2").Value = Application.VLookup(lookfor, srchRange, 6, False)
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Change this:
If plik = False Then Exit Sub
Workbooks.Open Filename:=plik
Set Baza1 = ThisWorkbook 'activesheet
Set Baza2 = Workbooks(plik) 'external workbook
To this:
If plik = False Then Exit Sub
Set Baza2 = Workbooks.Open(Filename:=plik)
Set Baza1 = ThisWorkbook 'activesheet
since plik is giving you a full filename (including a path) I don't think it can be used as an index for the Workbooks collection
See here: https://msdn.microsoft.com/en-us/vba/excel-vba/articles/workbook-object-excel

If statement to delete tab if there but move on if page is not there

I have a code that deletes a tab in the worksheet then runs another code. I am currently running into an issue that if the sheet is not there the code gives me an error... I'm wondering if I could make an if statement that looks if the tab is there and if not it moves on and if it is there it will delete it. I have the code that I have written already posted below but I have no idea how to do the if in the delete section.
Thanks!
Sub delete()
Dim ws As Worksheet
Set ws = Worksheets("Workbench Report")
Application.DisplayAlerts = False
ws.delete
Call Sorting
End Sub
Check if the sheet exists first:
Sub delete()
Dim ws As Worksheet
If WorksheetExists("Workbench Report") Then
Set ws = Worksheets("Workbench Report")
Application.DisplayAlerts = False
ws.delete
Call Sorting
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 = 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
Try this
Sub delete()
Dim i As Integer
i = 1
Application.DisplayAlerts = False
While i <= ActiveWorkbook.Worksheets.Count
Sheets(i).Select
If ActiveSheet.Name = "Workbench Report" Then
ActiveSheet.delete
End If
i = i + 1
Wend
Call Sorting
Application.DisplayAlerts = True
End Sub