VBA code cannot run in shared workbook - vba

Question

Just a concern regarding shared workbooks. I have a script that moves a certain row to the appropriate sheet based on cell values.
When I copy the row, the format is usually pasted in unshared workbooks.
However, in shared workbooks, formats are completely ignored.
I can't seem the find the reason why....
Any help would be greatly appreciated.
Thanks
Sub RunScriptButton_Click()
'On Error GoTo CleanFail
If MsgBox("Run Script?", vbYesNo, "Run Script") = vbNo Then
Exit Sub
End If
'Disables screen flashing when the information is updated
Application.ScreenUpdating = False
Dim project As String, ws As Worksheet, ignoredSheets As Object, scheduleSheets As Object
Dim legendSht As Worksheet, masterSht As Worksheet
Dim i As Integer, j As Integer, k As Integer, x As Integer, y As Integer, z As Integer
Dim lastrow As Integer, lastcoln As Integer, lastrow2 As Integer, lastrow3 As Integer, lastRowLegend As Integer
Dim rowht As Double, rowht2 As Double
Dim count As Integer, SAcount As Integer
Dim ID As String, name As Range, allppl As Range, allppl2 As Range
Dim month_col As Range, month_col_no As Integer, next_month_col As Range, next_month As Integer
Dim mcount1 As Integer, mcount2 As Integer, first As Integer, secnd As Integer
Dim monthrow As Integer, script_info_row As Integer, proj_coln As Integer, name_coln As Integer, assist_coln As Integer
Set legendSht = ThisWorkbook.Worksheets("Legend")
Set masterSht = ThisWorkbook.Worksheets("Master Schedule")
'----------------------------------------------------------
' Set the worksheet names to be ignored by the script (non-schedule sheets)
' Add additional exceptions by adding a new item to the dictionary with "Sheet Name", [next number]
Set ignoredSheets = CreateObject("Scripting.Dictionary")
ignoredSheets.Add "Legend", 1
ignoredSheets.Add "Master Schedule", 2
ignoredSheets.Add "Surveyor Overview", 3
'----------------------------------------------------------
lastRowLegend = legendSht.UsedRange.Row - 1 + legendSht.UsedRange.Rows.count
script_info_row = legendSht.Range(legendSht.Cells(1, 1), legendSht.Cells(lastRowLegend, 1)).Find(what:="Script Information").Row + 1
With masterSht
'Find last row with data on the master schedule sheet
Set tempRange = .Cells(.Rows.count, "B").End(xlUp)
lastrow = tempRange.Row
'Find last column with data on the master schedule sheet
If .Cells(2, .Columns.count) <> vbNullString Then
Set tempRange = .Cells(2, .Columns.count)
lastcoln = tempRange.Column
Else
Set tempRange = .Cells(2, .Columns.count).End(xlToLeft)
lastcoln = tempRange.Column
End If
proj_coln = .Range(.Cells(1, 1), .Cells(1, lastcoln)).Find(what:="Project").Column
name_coln = .Range(.Cells(1, 1), .Cells(1, lastcoln)).Find(what:="Name").Column
assist_coln = .Range(.Cells(1, 1), .Cells(1, lastcoln)).Find(what:="Assistant").Column
'startCol = .Range(.Cells(1, 1), .Cells(1, lastcoln)).Find(what:=CStr(lastUpdateDate + 1)).Column
'endCol = .Range(.Cells(1, 1), .Cells(1, lastcoln)).Find(what:=CStr(currentDate)).Column
End With
Set scheduleSheets = CreateObject("Scripting.Dictionary")
'Loops through each worksheet except for legend and master schedule worksheet and deletes all information
For Each ws In ThisWorkbook.Worksheets
If Not ignoredSheets.Exists(ws.name) Then
ws.Cells.Delete
'Repositions buttons that get shoved off the page?
'For Each Control In ws.Shapes
' If Control.Type = msoOLEControlObject Then
' Control.Top = 48
' Control.Left = 9.75
' End If
'Next Control
'MsgBox Mid(ws.name, InStr(ws.name, "(") + 1, InStr(ws.name, ")") - InStr(ws.name, "(") - 1)
scheduleSheets.Add Mid(ws.name, InStr(ws.name, "(") + 1, InStr(ws.name, ")") - InStr(ws.name, "(") - 1), ws.Index
End If
Next ws
'copies the headers and dates from master schedule sheet
With masterSht
.Range(.Cells(1, 1), .Cells(2, lastcoln)).Copy
rowht = .Rows(1).RowHeight
rowht2 = .Rows(2).RowHeight
End With
'pastes the copied headers into every sheet except for ignored sheets
For Each ws In ThisWorkbook.Worksheets
If Not ignoredSheets.Exists(ws.name) Then
With ws
.Range("A1").PasteSpecial xlPasteColumnWidths
.Range("A1").PasteSpecial xlPasteFormats
.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
.Rows(1).RowHeight = rowht
.Rows(2).RowHeight = rowht2
End With
End If
Next ws
'Checks number in Project column of Master Schedule and copies row into sheet with matching number between brackets in sheet name
For i = 3 To lastrow
project = masterSht.Cells(i, proj_coln)
'Loop through stored sheet project numbers and compare to current row to find the correct sheet to copy to
For Each strKey In scheduleSheets.Keys()
If InStr(project, strKey) <> 0 Then
masterSht.Range(masterSht.Cells(i, 1), masterSht.Cells(i, lastcoln)).Copy
ThisWorkbook.Sheets(scheduleSheets.Item(strKey)).Range("A" & i).PasteSpecial xlPasteColumnWidths
ThisWorkbook.Sheets(scheduleSheets.Item(strKey)).Range("A" & i).PasteSpecial xlPasteFormats
ThisWorkbook.Sheets(scheduleSheets.Item(strKey)).Range("A" & i).PasteSpecial xlPasteValuesAndNumberFormats
ThisWorkbook.Sheets(scheduleSheets.Item(strKey)).Range("A" & i).PasteSpecial xlPasteComments
'If only one project number in this item, then break out of looping through sheet names and go to next row in schedule
If InStr(project, "/") = 0 Then
Exit For
End If
End If
Next
Next i
'Deletes empty rows in sheets other than legend and master schedule
For Each ws In ThisWorkbook.Worksheets
If Not ignoredSheets.Exists(ws.name) Then
ws.Cells.EntireColumn.Hidden = False
With ws.UsedRange
For j = .Rows.count To 3 Step -1
If Application.WorksheetFunction.CountA(.Rows(j).EntireRow) = 0 Then
.Rows(j).EntireRow.Delete
End If
Next j
End With
lastrow = ws.UsedRange.Rows.count
'Count the number of survey assistants in each project worksheet
SAcount = Application.WorksheetFunction.CountIfs(ws.Range(ws.Cells(3, name_coln), ws.Cells(lastrow, name_coln)), "SA:*")
'Crew count labels
ws.Range("A" & lastrow + 1) = "Total Crew Count: " & lastrow - 2 - SAcount
ws.Range("E" & lastrow + 2) = "Double Crew Count"
ws.Range("E" & lastrow + 3) = "Single Crew Count"
'Get total crew count by counting number of party chiefs (hide SAs)
Set allppl = ws.Range(ws.Cells(3, name_coln), ws.Cells(lastrow, name_coln))
For Each name In allppl
If Left(name, 3) = "SA:" Then
name.EntireRow.Hidden = True
End If
Next name
'Tally active crews for each day
For j = assist_coln To lastcoln
'Find 3 letter code for current project sheet
ID = Application.WorksheetFunction.Index(Sheet1.Range(Sheet1.Cells(script_info_row, 1), Sheet1.Cells(lastRowLegend, 3)), _
Application.WorksheetFunction.Match(ws.name, Sheet1.Range(Sheet1.Cells(script_info_row, 1), Sheet1.Cells(lastRowLegend, 1)), 0), 2)
'Count number of active crews for the current day
count = COUNTIFv(ws.Range(ws.Cells(2, j), ws.Cells(lastrow, j)), "*" & ID & "*")
ws.Cells(lastrow + 1, j).Value = count
Next j
'Unhide all cells
ws.Cells.EntireRow.Hidden = False
'Hide all crew except survey assistants to determine number of 2-man crews
If lastrow - 2 - SAcount > 0 Then
For Each name In allppl
If Left(name, 3) <> "SA:" Then
name.EntireRow.Hidden = True
End If
Next name
End If
'Tally active 2-man crews for each day
For j = assist_coln To lastcoln
'ID = Application.WorksheetFunction.Index(Sheet1.Range(Sheet1.Cells(script_info_row, 1), Sheet1.Cells(lastRowLegend, 3)), _
'Application.WorksheetFunction.Match(ws.name, Sheet1.Range(Sheet1.Cells(script_info_row, 1), Sheet1.Cells(lastRowLegend, 1)), 0), 2)
count2 = COUNTIFv(ws.Range(ws.Cells(2, j), ws.Cells(lastrow, j)), "*" & ID & "*")
ws.Cells(lastrow + 2, j).Value = count2 'Active two-man crews for current date
ws.Cells(lastrow + 3, j).Value = ws.Cells(lastrow + 1, j) - count2 'One-man crew = Total crew - 2M crew
Next j
ws.Cells.EntireRow.Hidden = False
'Hide all schedule columns prior to current day
month_col_no = ws.Range(ws.Cells(2, 1), ws.Cells(2, lastcoln)).Find(what:=Format(Now, "m/d/yyyy")).Column
ws.Range(ws.Cells(1, assist_coln), ws.Cells(1, month_col_no - 1)).EntireColumn.Hidden = True
ws.Activate
ActiveWindow.ScrollRow = 1
'Tabulate monthly crew counts
lastrow3 = ws.UsedRange.Rows.count
monthrow = lastrow3 + 1
For i = Month(Date) To 12
month_col_no = ws.Range(ws.Cells(2, 1), ws.Cells(2, lastcoln)).Find(what:=i & "/1/" & Year(Date)).Column
If i <> 12 Then
next_month = ws.Range(ws.Cells(2, 1), ws.Cells(2, lastcoln)).Find(what:=i + 1 & "/1/" & Year(Date)).Column
Else
next_month = ws.Range(ws.Cells(2, 1), ws.Cells(2, lastcoln)).Find(what:="12/31/" & Year(Date)).Column + 1
End If
mcount1 = Application.Sum(ws.Range(ws.Cells(lastrow3 - 1, month_col_no), ws.Cells(lastrow3 - 1, next_month - 1)))
mcount2 = Application.Sum(ws.Range(ws.Cells(lastrow3, month_col_no), ws.Cells(lastrow3, next_month - 1)))
ws.Cells(monthrow, 1) = MonthName(i) & " Double Crew Total: " & mcount1
ws.Cells(monthrow + 1, 1) = MonthName(i) & " Single Crew Total: " & mcount2
monthrow = monthrow + 2
Next i
End If
Next ws
With masterSht
.Activate
ActiveWindow.ScrollRow = 1
month_col_no = .Range(.Cells(2, 1), .Cells(2, lastcoln)).Find(what:=Month(Date) & "/" & Day(Date) & "/" & Year(Date)).Column
.Range(.Cells(1, assist_coln + 1), .Cells(1, month_col_no - 1)).EntireColumn.Hidden = True
End With
'enables screen flash and auto calculation again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'CleanExit:
'Cleanup code
MsgBox "Process complete"
' Exit Sub
'CleanFail:
' Raise Err.Number
' Resume CleanExit
' Resume
End Sub

Answer 1

Shared workbooks have limitations. The biggest one is that they can become corrupt at any time and are impossible to troubleshoot because their behaviour is not consistent.
Avoid shared workbooks.