Question

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

我们遇到了共享工作簿的主要问题，因此作为快速修复，我编写了一些代码，将大量工作表从共享工作簿中移出到各个用户可以独立打开的工作簿中。

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

当我尝试将它们移回时，它会将工作表“复制”回主工作簿，但将工作表保留在单个工作簿中，并且不会更新公式（事实上它似乎会破坏它们，很多＃过程后的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

将WorkSheets从一个工作簿移动到另一个工作簿并更新公式（链接）

0 个答案: