richh
Board Regular
- Joined
- Jun 24, 2007
- Messages
- 245
- Office Version
- 365
- 2016
Hi all,
I have a Worksheet_Change function and a Workbook_BeforeSave function in my master file. When the user selects a specific value in the target field of the worksheet, it will cause the workbook to save. The BeforeSave function kicks in and attempts to send updates to/get updates from a slave file in another directory. For some reason, queuing up the BS function this way causes the second workbook to not open. The BS function seems to work (at least somewhat) fine by itself.
********************************
Another issue I keep getting is that if I stop the debugger in any one of these functions causes them to no longer work at all until I completely close all Excel windows and start up again. Is there any way I can get these to start back up without abandoning ship?
I have a Worksheet_Change function and a Workbook_BeforeSave function in my master file. When the user selects a specific value in the target field of the worksheet, it will cause the workbook to save. The BeforeSave function kicks in and attempts to send updates to/get updates from a slave file in another directory. For some reason, queuing up the BS function this way causes the second workbook to not open. The BS function seems to work (at least somewhat) fine by itself.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim uAns As Integer
Dim newA As Variant
If Target.Column = 9 Then
If Target.Value = "Reassigned" Then
uAns = MsgBox("Please ensure that the previously assigned analyst's initials are still on this row before continuing." & _
" The program will not be able to remove the assignment from their workbook otherwise." & vbNewLine & vbNewLine & _
"Are you sure you want to continue? You may update the field after this action has completed.", vbYesNo)
If uAns = vbYes Then
Dim good2go As Boolean
good2go = False
Target.Offset(0, 11) = "RE"
ThisWorkbook.Save 'Error occurs here****************************************************
Do Until good2go = True
newA = InputBox("The assignment has been removed from the previous analyst. Please enter the initials of the new analyst to whom you want to assign this task.")
If UCase(CStr(newA)) <> "AA" Or UCase(newA) <> "BB" Or UCase(newA) <> "CC" Or UCase(newA) <> "DD" Or UCase(newA) <> "EE" Or UCase(newA) <> "FF" Then
MsgBox "ERROR. Enter the initials of one of the analysts."
Else
good2go = True
End If
Loop
Target.Offset(0, -2) = newA
Target.Offset(0, 11) = "New"
ThisWorkbook.Save 'Will then reassign to new analyst
MsgBox "Reassignment complete."
Else
Exit Sub
End If
End If
End If
End Sub
Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim wb As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lRow As Integer
Dim lRow2 As Integer
Dim path As String
Dim fName As String
Dim fullP As String
Dim aName As String
Dim uDates As Integer
Dim cRng As Range
Dim dRng As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("FY 18-19")
path = "path"
fName = Dir(path & "\*.xlsm", vbNormal)
If Len(fName) = 0 Then Exit Sub
Do Until fName = ""
fullP = path & "\" & fName
Set wb2 = Workbooks.Open(fullP) 'Error occurs here *********************************************
Set ws2 = wb2.Worksheets("FY 18-19")
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
lRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
aName = Mid(fName, 7, 2)
For i = 2 To lRow 'send new assignments to analyst
If ws.Cells(i, 7).Value = aName Then
If ws.Cells(i, 20) = "New" Then
Set cRng = ws.Range("A" & i & ":T" & i)
Set dRng = ws2.Range("A" & lRow2 + 1 & ":T" & lRow2 + 1)
dRng.Value = cRng.Value 'copy/paste new assignment in analyst's file
lRow2 = lRow2 + 1 'move to the next row
ws.Cells(i, 20) = "No Change" 'change the flag in master file
ElseIf ws.Cells(i, 20) = "RE" Then 'when the task has been reassigned...
For m = 2 To lRow
If ws2.Cells(m, 6) = ws.Cells(i, 6) And _
ws2.Cells(m, 7) = ws.Cells(i, 7) And _
ws2.Cells(m, 8) = ws.Cells(i, 8) Then
ws2.Rows(m).EntireRow.Delete 'check to ensure that the key fields match and then delete the assignment in the analyst's file
Exit For
End If
Next m
End If
End If
Next i
For j = 2 To lRow2 'check for updates from analyst
If ws2.Cells(j, 20).Value <> "New" And ws2.Cells(j, 20).Value <> "No Change" Then
For K = 2 To lRow
If ws.Cells(K, 20) <> "Completed" Then
If ws.Cells(K, 6).Value = ws2.Cells(j, 6).Value And _
ws.Cells(K, 7).Value = ws2.Cells(j, 7).Value And _
ws.Cells(K, 8).Value = ws2.Cells(j, 8).Value Then
Set cRng = ws2.Range("A" & j & ":T" & j)
Set dRng = ws.Range("A" & K & ":T" & K)
dRng.Value = cRng.Value 'check key fields and then update corresponding row in master
If ws2.Cells(j, 20).Value <> "Completed" Then
ws2.Cells(j, 20).Value = "No Change"
End If
End If
End If
Next K
End If
Next j
wb2.Close savechanges:=True
fName = Dir()
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True
End SubAnother issue I keep getting is that if I stop the debugger in any one of these functions causes them to no longer work at all until I completely close all Excel windows and start up again. Is there any way I can get these to start back up without abandoning ship?
Last edited:
