Reputation: 15
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
Upvotes: 0
Views: 60
Reputation: 15
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.
Upvotes: 0
Reputation: 19722
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
Upvotes: 1
Reputation: 7735
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")
Upvotes: 0