【作業効率】【Excel】excelでもメールでもwebでもシンプルにテキストのみ貼り付ける うざくないマクロ【マクロ】


notepengreen-min

概要

テキストの値貼り付けに近いですが、もう少し柔軟に貼り付けパターンに対応しました。

使い方

この前半だけで良いです。 マクロだとundoが聞かないのが痛い・・・ クイックアクセスツールバーに設定すると楽です。四角で囲われたAアイコンを私は使ってます。 Excelマクロざっくり設定方法
Sub 値の貼り付け()
'
' 値の貼り付け Macro
'

'

  If IsCBFormatAvailable(xlClipboardFormatLink) Then


        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
  ElseIf IsCBFormatAvailable(xlClipboardFormatText) Then

    
        ActiveSheet.PasteSpecial Format:="テキスト", Link:=False, DisplayAsIcon:= _
            False
    Else
        ' その他...Excel でも Shape とか Graph がありますよね
        ActiveSheet.Paste

    End If
End Sub
' // 指定したフォーマットのデータがクリップボードにあるか?
'
Public Function IsCBFormatAvailable(ByVal wFormat As XlClipboardFormat) As Boolean
  
    Dim fmt As Variant
    For Each fmt In Application.ClipboardFormats
        If CLng(fmt) = wFormat Then
            IsCBFormatAvailable = True
            Exit For
        End If
    Next

End Function
空行を詰める処理やちょっと余計な処理を足す場合はこちら。
Sub 値の貼り付け()
'
' 値の貼り付け Macro
'

'

  If IsCBFormatAvailable(xlClipboardFormatLink) Then


        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
  ElseIf IsCBFormatAvailable(xlClipboardFormatText) Then

    
        ActiveSheet.PasteSpecial Format:="テキスト", Link:=False, DisplayAsIcon:= _
            False
    Else
        ' その他...Excel でも Shape とか Graph がありますよね
        ActiveSheet.Paste

    End If
    '空行削除
    '(ある、なし、ある、なし:1つめのなし(空行)を詰める、2重空行:1つ詰める)
    '  + 2行下に飛び出してチェックしちゃう。
    If Selection.Rows.Count >= 3 And 1 > 2 Then
        r = Selection.row
        c = Selection.column
        h = Selection.Rows.Count
        f = 0
        j = h
        
        For i = 0 To h - 2
            j = j - 1
            If j < 0 Then Exit For
            'MsgBox "" & f & ":" & Cells(r + i, c).Value & " , " & Cells(r + i + 1, c).Value
            If f = 0 And Cells(r + i, c).Value <> "" And Cells(r + i + 1, c).Value = "" _
                And Cells(r + i + 2, c).Value <> "" And Cells(r + i + 3, c).Value = "" Then
                
                Call tumeru(r + i, c, h)
                h = h - 1
                f = 1
                i = i - 1
            ElseIf Cells(r + i, c).Value = "" And Cells(r + i + 1, c).Value = "" Then
                Call tumeru(r + i, c, h)
                h = h - 1
                f = 1
                i = i - 1
            Else
                f = 0
            End If
        Next
    End If
    
    
    '3行目が1行目と同じなら3行目を削除
    If Selection.Rows.Count = 3 Then
        If Cells(Selection.row + 2, Selection.column).Value = Cells(Selection.row, Selection.column).Value Then
             Cells(Selection.row + 2, Selection.column).Value = ""
        Else
            Cells(Selection.row + 2, Selection.column).Select
            fillText
        End If
    End If

End Sub

Sub tumeru(ByVal r As Integer, ByVal c As Integer, ByVal h As Integer)
    For i = 1 To h - 1
        Cells(r + i, c).Value = Cells(r + i + 1, c).Value
    Next
End Sub


' // 指定したフォーマットのデータがクリップボードにあるか?
'
Public Function IsCBFormatAvailable(ByVal wFormat As XlClipboardFormat) As Boolean
  
    Dim fmt As Variant
    For Each fmt In Application.ClipboardFormats
        If CLng(fmt) = wFormat Then
            IsCBFormatAvailable = True
            Exit For
        End If
    Next

End Function
Delicious にシェア
Digg にシェア
reddit にシェア
LinkedIn にシェア
LINEで送る
email this
Pocket

1,835 views.



コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です