Vba 将公式从一张图纸复制到另一张图纸

您好，我目前正试图编写一个程序，将大量Excel文件迁移到另一个目录。对于这个用例，我拼凑了以下代码片段。搜索Excel文件中的所有链接，并将其写入此文件中的另一个工作表中

Sub LinkCheck_detail()

Dim aLinks           As Variant
Dim i                As Integer
Dim ws               As Worksheet
Dim anyWS            As Worksheet
Dim anyCell          As Range
Dim reportWS         As Worksheet
Dim nextReportRow    As Long
Dim shtName          As String
Dim bWsExists        As Boolean


shtName = "Verknuepfungen_detail"

'Löscht Datenblatt falls es bereits exisitiert.
Sheets("Verknuepfungen_detail").Delete

' Sheet mit den Verknuepfungen anlegen
For Each ws In Application.Worksheets
    If ws.Name = shtName Then bWsExists = True
Next ws

If bWsExists = False Then
    Application.DisplayAlerts = False
    Set ws = ActiveWorkbook.Worksheets.Add(Type:=xlWorksheet)
    ws.Name = shtName
    ws.Select
    ws.Move After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
    Application.DisplayAlerts = True
End If

    ' Komplettes Workbook analysieren auf Verknuepfungen
Set reportWS = ThisWorkbook.Worksheets(shtName)
    reportWS.Cells.Clear
    reportWS.Range("A1") = "Sheet"
    reportWS.Range("B1") = "Zelle"
    reportWS.Range("C1") = "Formel"
    reportWS.Range("A1:C1").Font.Bold = True

    aLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(aLinks) Then

        ' Wenn Verknuepfungen gefunden dann diese in Ergebnis schreiben
        For Each anyWS In ThisWorkbook.Worksheets
            If anyWS.Name <> reportWS.Name Then
                For Each anyCell In anyWS.UsedRange
                    If anyCell.HasFormula Then
                        If InStr(anyCell.formula, "[") > 0 Then
                            nextReportRow = reportWS.Range("A" & Rows.Count).End(xlUp).Row + 1
                            reportWS.Range("A" & nextReportRow) = anyWS.Name
                            reportWS.Range("B" & nextReportRow) = anyCell.Address
                            reportWS.Range("C" & nextReportRow) = "'" & anyCell.formula
                        End If
                    End If
                Next
            End If
        Next
    Else
        MsgBox "Keine Verknüpfungen gefunden in der Datei."
    End If

    reportWS.Columns("A:C").EntireColumn.AutoFit
    ' Zuruecksetzen der Hilfs-Variablen
    Set reportWS = Nothing
    Set ws = Nothing
End Sub

因此，这将为my留下一个具有以下列的新工作表： 表、单元格、公式

现在我需要把这些写回我从哪里得到的纸上

Sub UpdateLinksFormula()

    Dim ws As Worksheet
    Dim targetWS As String
    Dim sourceWS As String

    Dim sourceCell As Range
    Dim targetCell As String
    Dim newFormula As String
    Dim i As Integer ' Variable fuer Sheets Count
    Dim rowCount As Integer ' Variable fuer Rows Count
    Dim j As Integer ' Variable fuer Schleife
    Dim bWsExists As Boolean

    sourceWS = "Verknuepfungen_detail"

    ' Auf Arbeitsblatt mit Verknuepfungen springen
    For i = 1 To Sheets.Count
        If Sheets(i).Name = sourceWS Then
        bWsExists = True: Exit For
    End If
    Next i

    If bWsExists Then
        Sheets(sourceWS).Select
    Else
        Beep
        MsgBox "Verknuepfungen_detail nicht gefunden!"
    End If

    ' Groesse bestimmen
    rowCount = Range("A1").End(xlDown).Row
    ' Debug.Print (j)

    ' Schleife zum schreiben der aktualisierten Links
    For j = 2 To rowCount
        targetWS = Cells(j, 1)
        targetCell = Cells(j, 2)
        newFormula = Cells(j, 3)

        Debug.Print (targetWS)
        Debug.Print (targetCell)
        Debug.Print (newFormula)

        ' Pseudocode
        ' Sheets(targetWS)!.Cell(targetCell).formula = newFormula

        Sheets("targetWS").Range("targetCell").formula = newFormula

    Next j

End Sub

问题是它根本不起作用，我用“”试过了，没有等等。但它似乎就是不起作用

我遇到的第二个问题是如何使这件事自动化，这样我就不会只更新一个Excel文件，而是更新数百个Excel文件

非常感谢您的帮助。

工作表（targetWS）.Range（targetCell）.formula=newFormula

---

试试这个。

是不是有错误？如果是，那么在哪里？sheetws（“targetWS”）.Range（“targetCell”）.formula=newFormula在那里我得到一个索引越界错误。为什么不简单地使用

Workbook.ChangeLink

方法呢？我会试试看它是否有效。这是否也会更改名称管理器和VBA代码中的链接？它显示了Excel 2013，我们在这里使用2010。它与数据选项卡-连接组-编辑链接-更改源的操作相同。有没有可能解释一下它的适用范围，而不是说“在这里，试试这个…”？它是在伪代码注释下运行的。但我目前正在尝试带有ChangeLink函数的版本，因为这样会有更好的性能。

Sub UpdateLinksFormula()

    Dim ws As Worksheet
    Dim targetWS As String
    Dim sourceWS As String

    Dim sourceCell As Range
    Dim targetCell As String
    Dim newFormula As String
    Dim i As Integer ' Variable fuer Sheets Count
    Dim rowCount As Integer ' Variable fuer Rows Count
    Dim j As Integer ' Variable fuer Schleife
    Dim bWsExists As Boolean

    sourceWS = "Verknuepfungen_detail"

    ' Auf Arbeitsblatt mit Verknuepfungen springen
    For i = 1 To Sheets.Count
        If Sheets(i).Name = sourceWS Then
        bWsExists = True: Exit For
    End If
    Next i

    If bWsExists Then
        Sheets(sourceWS).Select
    Else
        Beep
        MsgBox "Verknuepfungen_detail nicht gefunden!"
    End If

    ' Groesse bestimmen
    rowCount = Range("A1").End(xlDown).Row
    ' Debug.Print (j)

    ' Schleife zum schreiben der aktualisierten Links
    For j = 2 To rowCount
        targetWS = Cells(j, 1)
        targetCell = Cells(j, 2)
        newFormula = Cells(j, 3)

        Debug.Print (targetWS)
        Debug.Print (targetCell)
        Debug.Print (newFormula)

        ' Pseudocode
        ' Sheets(targetWS)!.Cell(targetCell).formula = newFormula

        Sheets("targetWS").Range("targetCell").formula = newFormula

    Next j

End Sub