VBAを使える環境なら
Sub セル範囲をクリップボードに()
Dim myRng As Range
Dim n As Long
Dim cntCol As Long
Dim cntRow As Long
Dim myMax() As Long
Dim myVar() As String
Dim myStr As String
Dim myFormula As String
Dim flgFormula As Boolean
Dim i As Long
Dim j As Long
Dim Filj As String
Dim Sepj As String
Dim meNum As Variant
Dim myFlg As Boolean
Dim ForConFlg As Boolean
Dim myData As Object
Set myData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
If TypeName(Selection) <> "Range" Then
MsgBox "セル範囲選択して!"
Exit Sub
End If
Filj = " " '半角スペース
Sepj = " " '全角スペース
'フィルコピー方向指定
myFlg = False
Do
meNum = CVar(InputBox("1〜3の番号入れて" & _
Chr(13) & "0:数式なし" & _
Chr(13) & "1:数式すべて貼り付け" & _
Chr(13) & "2:下方向・↓" & _
Chr(13) & "3:右方向・→", _
"フィルコピー方向指定", "2"))
If meNum = "" Then Exit Sub
If meNum > 3 Or meNum < 0 Then
MsgBox "0〜3の番号入れて", vbOKOnly
Else: myFlg = True
End If
Loop While myFlg = False
With Selection
For n = 1 To .Areas.Count
Set myRng = .Areas(n)
With myRng
cntCol = .Columns.Count
cntRow = .Rows.Count
ReDim myMax(cntCol)
ReDim myVar(cntRow, cntCol)
myVar(0, 0) = Filj '半角スペース
For i = 1 To cntRow
myVar(i, 0) = .Item(i, 1).Row
Next i
myMax(0) = LenB(StrConv(myVar(cntRow, 0), vbFromUnicode))
For j = 1 To cntCol
flgFormula = False
myVar(0, j) = Left$(.Item(1, j).Address(False, False), 1)
For i = 1 To cntRow
With .Item(i, j)
If .Text = "" Or .Font.ColorIndex = 2 Then
myVar(i, j) = Filj '半角スペース
Else
myVar(i, j) = .Text
End If
If meNum = 1 Or meNum = 2 Then
If flgFormula = False And .HasFormula Then
myFormula = myFormula & _
.Address(False, False) & vbCrLf & _
.Formula & vbCrLf
If .HasArray = True Then
myFormula = myFormula & _
"Ctrl+Shift+Enter同時押し" & vbCrLf
End If
If meNum = 2 Then
myFormula = myFormula & _
"下方向・↓" & vbCrLf
flgFormula = True
End If
End If
On Error Resume Next
myFormula = myFormula & _
.Address(False, False) & vbCrLf & _
"入力規則:リスト▼:元の値:" & vbCrLf & _
.Validation.Formula1 & vbCrLf
On Error GoTo 0
If ForConFlg = False And .FormatConditions.Count > 0 Then
myFormula = myFormula & _
.Address(False, False) & vbCrLf & _
"条件付書式:数式を使用して〜▼" & vbCrLf & _
.FormatConditions(1).Formula1 & vbCrLf
ForConFlg = True
End If
End If
End With
If myMax(j) < LenB(StrConv(myVar(i, j), vbFromUnicode)) Then
myMax(j) = LenB(StrConv(myVar(i, j), vbFromUnicode))
End If
Next i
Next j
For i = 0 To cntRow
flgFormula = False
For j = 0 To cntCol
myStr = myStr & String(myMax(j) - _
LenB(StrConv(myVar(i, j), vbFromUnicode)), Filj) _
& myVar(i, j) & String(2, Filj) '半角スペース2個
If meNum = 3 Then
If i > 0 And j > 0 Then
With .Item(i, j)
If flgFormula = False And .HasFormula Then
myFormula = myFormula & _
.Address(False, False) & vbCrLf & _
.Formula & vbCrLf
If .HasArray = True Then
myFormula = myFormula & _
"Ctrl+Shift+Enter同時押し" & vbCrLf
End If
myFormula = myFormula & _
"右方向・→" & vbCrLf
flgFormula = True
End If
End With
End If
End If
Next j
myStr = Left$(myStr, Len(myStr) - 1) & vbCrLf
Next i
End With
Next n
End With
myStr = Replace(myStr, String(2, Filj), Sepj) '半角スペース2個を全角スペースに
myStr = myStr & vbCrLf & myFormula
Set myData = GetObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
With myData
.SetText myStr
.PutInClipboard 'クリップボードに
End With
Set myData = Nothing
End Sub