VBA代码无法在共享工作簿中运行

Question

只关心共享工作簿。我有一个脚本，根据单元格值将特定行移动到适当的工作表。

当我复制该行时，格式通常会粘贴到非共享工作簿中。

但是，在共享工作簿中，格式完全被忽略。

我似乎无法找到原因....

任何帮助将不胜感激。

感谢

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

共享工作簿有局限性。最大的一个问题是，他们随时可能变得腐败，而且不可能排除故障，因为他们的行为不一致。

避免共享工作簿。