2

ワークブック (評価) にシート (質問) があり、質問シートの下部に、評価ワークブックからシート 2 (引用) をコピーし、引用番号に従って名前が付けられた新しいワークブックに貼り付けるボタンがあります。そして保存しました。

そのコードは次のとおりです。

Sub GetQuote()
    Range("AK548").Select
    Selection.Copy
    Range("AK549").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Dim Output As Workbook
    Dim FileName As String

    Set Output = Workbooks.Add
    FileName = ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Questions").Range("AK545").Value & ".xls"
    Output.SaveAs FileName

    Application.DisplayAlerts = False

    Output.Worksheets("Sheet1").Delete
    ThisWorkbook.Worksheets(2).Copy Before:=Output.Worksheets("Sheet2")
    Output.Worksheets(1).Name = "Sheet1"

    Application.DisplayAlerts = True
    Output.Protect Password:="12345"
    Output.Save
End Sub

ここで、この新しいコピーと見積もりシートの間に存在するリンクを削除し、値のみを残すつもりです。どうすればいいですか？

存在するリンクを削除する必要がある次のコードを見つけました。

Dim Cell As Range, FirstAddress As String, Temp As String
    'delete all links from selected cells
    Application.ScreenUpdating = False
    With Selection
        Set Cell = .Find("=*!", LookIn:=xlFormulas, searchorder:=xlByRows, _
        LookAt:=xlPart, MatchCase:=True)
        On Error GoTo Finish
        FirstAddress = Cell.Address
        Do
            Temp = Cell
            Cell.ClearContents
            Cell = Temp
            Set Cell = .FindNext(Cell)
        Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
    End With
Finish:

私が余分に行ったのは、シートに名前を付けてコピーするコードの下にこのコードを配置したことだけで、それは機能しませんでしたか?

では、これら 2 つのコードをどのように組み合わせれば、すべてがコピーされ、リンクが削除されるのでしょうか?

4

3 に答える 3

3

このコードは、アクティブなワークブック内のすべての接続を強制終了します...申し訳ありませんが、どこで入手したか思い出せません。

    'Kill Connections
    If ActiveWorkbook.Connections.Count > 0 Then
        For i = 1 To ActiveWorkbook.Connections.Count
        ActiveWorkbook.Connections.Item(1).Delete
        Next i
    Else
    End If

あなたのコードでテストすると、これはうまくいくようです：

    Dim Output As Workbook
Dim FileName As String

Set Output = Workbooks.Add
FileName = ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Questions").Range("A1").Value & ".xls"
Output.SaveAs FileName

Application.DisplayAlerts = False

Output.Worksheets("Sheet1").Delete
ThisWorkbook.Worksheets(2).Copy Before:=Output.Worksheets("Sheet2")
Output.Worksheets(1).Name = "Sheet1"

Output.Worksheets(1).Select
If ActiveWorkbook.Connections.Count > 0 Then
    For i = 1 To ActiveWorkbook.Connections.Count
    ActiveWorkbook.Connections.Item(1).Delete
    Next i
Else
End If

Application.DisplayAlerts = True
Output.Protect Password:="12345"
Output.Save
于 2013-06-18T09:59:06.143 に答える