エクセル2007値貼り付けのマクロの不具合を修正

一昨日と昨日の続き

gogowaten.hatenablog.com

エクセルの右クリックメーニューにマクロを登録してみた - 午後わてんのブログ - Yahoo!ブログ

http://blogs.yahoo.co.jp/gogowaten/11238274.html

エクセル2007で値貼り付けのマクロで：１のウィンドウのシートが勝手に切り替わる - 午後わてんのブログ - Yahoo!ブログ

http://blogs.yahoo.co.jp/gogowaten/11232703.html

値貼り付けのマクロには不具合があったのを直した

セル以外をコピーした状態で値貼り付けを実行するとエラーになるのは

値貼り付けをするxlPasteValuesがセル以外には対応していないから？

書き直してウェブブラウザからのコピーでHTML形式もテキスト形式で

貼り付けるようにしたのが↓

f:id:gogowaten:20191014141308p:plain

Sub 値貼り付け()
    '新しいウィンドウで複数のウィンドウを開いていると
    ':1のついたウィンドウのシートが勝手に切り替わるので
    'それを元に戻すから長くなった
    Dim fmt
    Dim textF, cellF As Boolean
    textF = False
    cellF = False
    
    fmt = Application.ClipboardFormats
    If fmt(1) Then 'クリップボードが空ならなにもしないで終了
       Exit Sub
    End If
    test = fmt(1)
 
    If Application.CutCopyMode = xlCut Then
        MsgBox ("切り取りでは実行できないのでコピーで実行して")
        Exit Sub
    End If
    
    For Each c In fmt 'クリップボードにテキスト形式かセル判定
        If c = 0 Then
            textF = True
        ElseIf c = 63 Or c = 8 Or c = 18 Or c = 20 Or c = 30 Then
            cellF = True
        End If
    Next
    
    If textF = False Then 'テキスト形式がなければ終了
        Exit Sub
    End If
        
    Application.ScreenUpdating = False
    Dim actS As Worksheet '貼り付け先のシート、アクティブシート
    Dim actN ':1のウィンドウのアクティブシートの名前
    Dim bName 'ブックの名前
    Dim wName '貼り付け先のウィンドウの名前
    Dim allW 'ウィンドウすべて、新しいウィンドウで開くで開かれているウィンドウ
    Dim val
        
    Set actS = ThisWorkbook.ActiveSheet
    bName = ActiveWorkbook.Name
    wName = Application.ActiveWindow.Caption
    
    ':1を探して新しいウィンドウで開くで複数ウィンドウがあるかどうかの判定
    Set allW = ActiveWorkbook.Windows
    For Each c In allW
        If Right(c.Caption, 2) = ":1" Then
            actN = c.ActiveSheet.Name
    'クリップボードがセルかどうかの判定
    'clipbordformatsの配列の数がセルだと24か23でそれ以外だともっと少なかったのでこれを利用は
    'やっぱり中止、必要なさそう
'            If cellF Or UBound(fmt) >= 23 Then    'セルの場合
            If cellF Then     'セルの場合
                Selection.PasteSpecial Paste:=xlPasteValues '値貼り付け
            Else                        'セル以外のテキストの場合
                ActiveSheet.PasteSpecial Format:="テキスト"
            End If
        ':1がつくウィンドウのアクティブシートを元に戻す
            Application.Windows(c.Caption).Activate
            Worksheets(actN).Activate
            Application.Windows(wName).Activate '貼り付け先のウィンドウをアクティブにする
            Application.ScreenUpdating = True
            Exit Sub
        End If
    Next
    
    '複数ウィンドウが無いとき
    'If cellF Or UBound(fmt) >= 23 Then
    If cellF Then
        Selection.PasteSpecial Paste:=xlPasteValues
    Else
        ActiveSheet.PasteSpecial Format:="テキスト"
    End If
    Application.ScreenUpdating = True
            
End Sub