3

アクティブなワークシートを新しいワークブックにコピーし、その新しいワークブックを保存して閉じようとしています。これは、アクティブなワークシートのフォーム (ボタン) をクリックするとトリガーされます。ボタンは、保存する前に新しいワークブックで削除されます。

アクティブなワークシートで数式を使用しています。値と追加の書式設定のみをコピーしようとしています。

新しいワークブックには値が表示されず、代わりに空のセルのみが表示されます (数式も表示されませんが、もちろん問題ありません)。具体的には、間接数式を含むセルをコピーするときに問題が発生するようです。元のワークブックの他のシートへの単純な参照を使用するセルでは問題ないようです。

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

Sub CopyRemoveFormAndSave()
    Dim RelativePath As String
    Dim shp As Shape
    Dim testStr As String

    ' Copy and Paste Active Sheet
    ActiveSheet.Copy
    With ActiveSheet.UsedRange
        .Value = .Value
    End With

    ' Remove forms
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 8 Then
            If shp.FormControlType = 0 Then
                testStr = ""
                On Error Resume Next
                testStr = shp.TopLeftCell.Address
                On Error GoTo 0
                If testStr <> "" Then shp.Delete
            Else
                shp.Delete
            End If
        End If
    Next shp

    ' Save New Workbook and Close
    Application.DisplayAlerts = False
    RelativePath = ThisWorkbook.Path & "\" & ActiveSheet.Name & "_Reporting_" & Format(Now, "yymmdd") & ".xlsx"
    ActiveWorkbook.SaveAs Filename:=RelativePath
    ActiveWorkbook.Close
    Application.DisplayAlerts = True

End Sub
4

2 に答える 2

3

ここでは、少し異なるアプローチを示します。

論理：

  1. ユーザーの一時ディレクトリにアクティブなワークブックのコピーを作成する
  2. コピーを開く
  3. 数式を値に変更します。残りの書式設定は変更されません。
  4. 不要なシートをすべて削除する
  5. 不要な図形を削除します。

コード: (試行錯誤)

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH As Long = 260

'~~> Function to get user's temp directoy
Function TempPath() As String
    TempPath = String$(MAX_PATH, Chr$(0))
    GetTempPath MAX_PATH, TempPath
    TempPath = Replace(TempPath, Chr$(0), "")
End Function

Sub CopyRemoveFormAndSave()
    Dim wb As Workbook, wbNew As Workbook
    Dim ws As Worksheet
    Dim wsName As String, NewName As String
    Dim shp As Shape

    Set wb = ThisWorkbook

    wsName = ActiveSheet.Name

    NewName = wsName & ".xlsm"

    wb.SaveCopyAs TempPath & NewName

    Set wbNew = Workbooks.Open(TempPath & NewName)

    wbNew.Sheets(wsName).UsedRange.Value = wbNew.Sheets(wsName).UsedRange.Value

    Application.DisplayAlerts = False
    For Each ws In wbNew.Worksheets
        If ws.Name <> wsName Then ws.Delete
    Next ws
    Application.DisplayAlerts = True

    For Each shp In wbNew.Sheets(wsName).Shapes
        If shp.Type = 8 Then shp.Delete
    Next

    '
    '~~> Do a save as for the new workbook if required.
    '
End Sub
于 2013-10-16T10:14:28.670 に答える