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
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