VBA代码无法在共享工作簿中运行
只是关心共享工作簿。 我有一个脚本，根据单元格值将特定的行移动到适当的工作表。
当我复制行时，格式通常粘贴在非共享工作簿中。
但是，在共享工作簿中，格式完全被忽略。
我似乎无法find原因….
任何帮助将不胜感激。
谢谢
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 共享工作簿有限制。 其中最大的一个就是随时可能腐败，不可能排除故障，因为他们的行为不一致。
避免共享工作簿。