0

我已经解决了这个问题，稍微调整了代码，现在它工作正常。我不会尝试发布新代码，因为每次我尝试都会在代码块上方和下方得到一些代码。

我们遇到了共享工作簿的主要问题，因此作为快速修复，我编写了一些代码以将多个工作表从共享工作簿移到单个工作簿，每个用户都可以独占打开这些工作簿。

当我移动它们（如上所述）时，它会从主工作簿中删除工作表，使用一个（相同的）工作表创建一个新工作簿并更新所有公式（链接成为新工作簿的外部）。

当我尝试将它们移回时，它将工作表“复制”回主工作簿，但将工作表留在单个工作簿中，并且不更新公式（实际上它似乎破坏了它们，很多 #REF 在过程）。

我想做的是从单个工作簿中删除工作表，将其移回主工作簿并更新链接。

这是我的代码：

Public Sub ResourceMerge()

'-- Rich Head, 5/12/2012
'-- Merges the separated resource worksheets into the main workbook (sledge hammer to fix
'-- shared workbooks issue) which has arisen since XP rollout

    'Handle errors
    On Error GoTo Err

    'Variables
    Dim wbResourceNames(1 To 20), cv, myName As String, _
        ws As Worksheet, _
        wb, targetwb As Workbook, _
        x, i As Integer

    'Before any changes made, backup the master workbook
    myName = ActiveWorkbook.Name                                        'Get current workbook name
    myName = Mid(myName, 1, Len(myName) - 4)                            'Remove the .xls"
    myName = myName & "_backup2_" & Format(Date, "d mmm yyyy") & ".xls" 'Add "_backup current date.xls"
    ActiveWorkbook.SaveCopyAs myName                                    'Save a copy with the new name
    Set targetwb = Application.ActiveWorkbook                           'Store the main workbook

    'Make the people control panel sheet active and select cell B8 (row above first name)
    Set ws = Sheets("People Control Panel")
    ws.Activate
    ActiveSheet.Range("B8").Activate

    'Loop down through the names (ignoring any Spare) to get all the resource names
    x = 0
    Do Until x = 20                                         'Assumes maximum 20 resources
        x = x + 1
        Debug.Print x
        ActiveCell.Offset(Rowoffset:=1).Activate            'Move down one cell
        If Left(ActiveCell.Value, 5) = "Spare" Then         'Ignore 'spare' rows
            GoTo Loopy
        End If
        wbResourceNames(x) = ActiveCell.Value               'Get the resource name
        Set wb = Workbooks.Open(wbResourceNames(x))         'Open the individual resource worksheet
        'Move sheet back into main workbook
        wb.Sheets(1).Move _
        after:=targetwb.Sheets(targetwb.Sheets("OFF SHORE"))
        wb.Close                                            'Close new workbook
Loopy:
    Loop                                                    'Do next resource

'    ActiveWorkbook.Save                                     'Save the reduced master

GoTo Endy                                                   'All done

Err:
    If Err = 9 Then                                         'Incorrect worksheet name?
        MsgBox "The VBA code has trapped an error ('subscript out of range'), this is likely to be " & _
            "because a resource name from the 'People Control Panel' (a hidden worksheet) does not " & _
            "match the name of the worksheet; please delete this spreadsheet and any individual " & _
            "spreadsheets created and start again (change the name of the backup sheet created - by " & _
            "removing the '_backup2 and date' from the filename, correct the worksheet name error, save " & _
            "the workbook and run the macro again)."
        GoTo Endy
    End If
    MsgBox "Oops... VBA code error, number: " & Err & ", with a description of: " & Error(Err)
Endy:
End Sub
4

0 回答 0