Close source workbook after opening opening and closing a receiver (2nd) workbook

spk

New Member
Joined
Jan 19, 2011
Messages
15
Hoping you can help. I am successfully using the following code (messy, I know) to take information from workbook 1, open workbook 2, update or append workbook 2, close workbook 2 then return to workbook 1 and close it overwriting any changes that have been made without prompting me. It works great in the first condition of the 'master' if/then/else statement, but fails to close the source workbook in the else condition of the 'master' if/then/else statement. What am I doing wrong?

Thanks so much!

Sub Auto_Save_And_Name_and_Close()


MsgBox "Has the property been photographed?", 32


If Sheets("Painting").Range("ai8").Value > 0 Then


MsgBox "This folio is missing critical information on the PAINTING tab such as name, address, telephone, time/date of estimate, etc. Go back and add any missing informtion, then save/close file again.", vbOKOnly + vbCritical, "ERROR - MISSING DATA"


End


Else




'SEGMENT 1: SAVES THE FILE IN A PARTICULAR DIRECTORY AS A NAME BASED ON PARTICULAR CELLS IN THE WORKSHEET
Dim newFile As String, fName1 As String, fname2 As String, fname3 As String, fname4 As String


fName1 = Sheets("Painting").Range("J4").Value
fname2 = Sheets("Painting").Range("J5").Value
fname3 = Sheets("Painting").Range("J3").Value
fname4 = Sheets("Painting").Range("J8").Value


newFile = fName1 & " - " & fname2 & " - " & fname3 & " - " & Format$(fname4, "mm-dd-yyyy") & ".xlsm"


ChDir _
"C:\SGPC\Dropbox\Client Folios"


Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=newFile, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
Application.DisplayAlerts = True


If Range("AA1").Value = "" Then


'SEGMENT 2: PLACES THE DATE FILE WAS LAST CHANGED (EFFECTIVELY THE CREATION DATE OF THE NEW FILE PRODUCED ABOVE)IN CELL P100
ActiveSheet.Range("P100") = _
Application.WorksheetFunction.Text(ActiveWorkbook.BuiltinDocumentProperties(12), "mm/dd/yy hh:mm:ss")
Range("P100").Select
Selection.Copy
Range("P100").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("AA1").Value = ("DATE EXISTS")








'SEGMENT 3: TAKES CERTAIN CELLS FROM THIS WORKSHEET, OPENS ANOTHER EXISTING WWORKBOOK, AND COPIES THE CONTENTS TO THE NEXT AVAILABLE ROW OF THE DESTINATION
Dim sWkBk As Workbook, rWkBk As Workbook, lRw As Long, sCell As Range, rCell As Range
Dim mRw As Long
Set sWkBk = ActiveWorkbook
Set sCell = sWkBk.Sheets("Control Panel").Range("P100")
' open the reciever workbook and select the destination sheet
Workbooks.Open FileName:="C:\SGPC\Dropbox\Masters\Client Financial Status.xlsm"
Set rWkBk = ActiveWorkbook
Set rCell = Intersect(ActiveSheet.Columns("P:P"), ActiveSheet.UsedRange)
lRw = rWkBk.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row


With sWkBk.Sheets("Control Panel")
.Range("A100:AI100").Copy
End With


For Each C In rCell
If C.Value = sCell.Value Then
mRw = C.Row
rWkBk.Sheets("Sheet1").Range("A" & mRw).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
'Save and Close workbook
rWkBk.Close SaveChanges:=True
Exit Sub
End If
Next C
rWkBk.Sheets("Sheet1").Range("A" & lRw + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
'Save and Close workbook
rWkBk.Close SaveChanges:=True
Range("A1").Select
ActiveWorkbook.Close SaveChanges:=True
'Application.Quit
Dim WbookCheck As Workbook

On Error Resume Next
Set WbookCheck = Workbooks("newFile")
On Error GoTo 0

If WbookCheck Is Nothing Then 'Closed
WbookCheck.Close SaveChanges:=True
ElseIf Application.ActiveWorkbook.Name = WbookCheck.Name Then
WbookCheck.Close SaveChanges:=True
Else
WbookCheck.Activate
End If






Else


'Application.DisplayAlerts = False
''SEGMENT 3: TAKES CERTAIN CELLS FROM THIS WORKSHEET, OPENS ANOTHER EXISTING WWORKBOOK, AND COPIES THE CONTENTS TO THE NEXT AVAILABLE ROW OF THE DESTINATION
''Dim sWkBk As Workbook, rWkBk As Workbook, lRw As Long, sCell As Range, rCell As Range
''Dim mRw As Long
Set sWkBk = ActiveWorkbook
Set sCell = sWkBk.Sheets("Control Panel").Range("P100")
'' open the reciever workbook and select the destination sheet
Workbooks.Open FileName:="C:\SGPC\Dropbox\Masters\Client Financial Status.xlsm"
Set rWkBk = ActiveWorkbook
Set rCell = Intersect(ActiveSheet.Columns("P:P"), ActiveSheet.UsedRange)
lRw = rWkBk.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row


With sWkBk.Sheets("Control Panel")
.Range("A100:AI100").Copy
End With


For Each C In rCell
If C.Value = sCell.Value Then
mRw = C.Row
rWkBk.Sheets("Sheet1").Range("A" & mRw).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
''Save and Close workbook
rWkBk.Close SaveChanges:=True
Exit Sub
End If
Next C
rWkBk.Sheets("Sheet1").Range("A" & lRw + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
''Save and Close workbook
rWkBk.Close SaveChanges:=True
sWkBk.Close SaveChanges:=True
Range("A1").Select
Set sWkBk = ActiveWorkbook
'ActiveWorkbook = newFile
'sWkBk.Close savechanges:=True
'ActiveWorkbook.Close savechanges:=True
'Application.DisplayAlerts = True
'Application.Quit


End If


'ActiveWorkbook.Close False


End If






On Error Resume Next
Set WbookCheck = newFile
On Error GoTo 0

If WbookCheck Is Nothing Then 'Closed
WbookCheck.Close SaveChanges:=True
ElseIf Application.ActiveWorkbook.Name = WbookCheck.Name Then
WbookCheck.Close SaveChanges:=True
Else
WbookCheck.Activate
End If










End Sub
 

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December

Forum statistics

Threads
1,223,277
Messages
6,171,147
Members
452,382
Latest member
RonChand

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top