指定した数の列を挿入する （軽負荷版）
現在の列（セル単体の選択、または通常の挿入のように列全体を選択してもよし）の左方向に指定した数の列を挿入します。
挿入方向と書式の引継ぎはEXCELで通常挿入した場合と同じです。
列数を自分で数える手間がないぶん少しだけ楽です。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub n列挿入する軽負荷版()
'現在の列の左方向にn列挿入する
'現在の列の左の書式がコピーされる
Dim n As Long
n = InputBox("挿入する列数を入力して下さい")
If n >= 1 And n <= 15000 Then
Range(Columns(ActiveCell.Column), Columns(ActiveCell.Column + n - 1)).Insert xlShiftToRight, xlFormatFromLeftOrAbove
ElseIf n > 15000 Then
MsgBox "数値が大きすぎます"
Else
MsgBox "1以上の数値を入力して下さい"
End If
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
指定した数の行を挿入する （軽負荷版）
前回投稿した後、CPUに負荷をかけない方法に気がついたので、再度仕切り直します(;^_^A ※負荷のかかるFor ～Nextをやめました
現在の行（セル単体の選択、または通常の挿入のように行全体を選択してもよし）の上方向に指定した数の行を挿入します。
挿入方向と書式の引継ぎはEXCELで通常挿入した場合と同じです。
行数を自分で数える手間がないぶん少しだけ楽です。
百万行を上限にしています。（・・・需要はあるのか？）
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub n行挿入する軽負荷版()
'現在の行の上方向にn行挿入する
'現在の行の上の書式がコピーされる
Dim n As Long
n = InputBox("挿入する行数を入力して下さい")
If n >= 1 And n <= 1000000 Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row + n - 1).Insert xlShiftDown, xlFormatFromLeftOrAbove
ElseIf n > 1000000 Then
MsgBox "数値が大きすぎます"
Else
MsgBox "1以上の数値を入力して下さい"
End If
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
指定した数の行を挿入する
簡単なマクロを作ってみました。
現在の行（セル単体の選択、または通常の挿入のように行全体を選択してもよし）の上方向に指定した数の行を挿入します。
挿入方向と書式の引継ぎはEXCELで通常挿入した場合と同じです。
行数を自分で数える手間がないぶん少しだけ楽です。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub n行挿入する()
'現在の行の上方向にn行挿入する
'現在の行の上の書式がコピーされる
Dim n As Integer
n = InputBox("挿入する行数を入力して下さい")
If n >= 1 And n <= 500 Then
For i = 1 To n
ActiveCell.EntireRow.Insert xlShiftDown, xlFormatFromLeftOrAbove
Next i
ElseIf n > 500 Then
MsgBox "数値が大きすぎます"
Else
MsgBox "1以上の数値を入力して下さい"
Exit Sub
End If
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
クリップボードのデータを可視セルのみに貼り付ける
以前書いた内容と重複しますが、だるまさんという方が作られた
素晴らしいマクロがありますので紹介をさせていただきます。
可視セルのみに貼り付けを行うというものです。
このマクロに自分好みの機能（選択中のセル位置から貼り付け）を付加したものを含め、紹介していきたいと思います。（二次創作という位置付けでご覧下さい・・・）
まず、下記のようなオートフィルター領域があります。
これをフィルタリングで「１」のみ抽出した状態にします。
ここで、Ｂ４セルに下記のようなクリップボードのデータを貼り付けると・・・
何だかおかしいですよね？
フィルターを解除してみると
非表示だったセルに、連続してデータが貼り付けられてしまっています。
ここで、今回紹介するマクロを使用すると、
可視セルのみに貼り付けすることができます。
ちなみに、セルを変えてマクロを実行すると、その位置から貼り付けが実行されます。
横方向にもデータがある場合はどうなるでしょうか？
EXCELでコピーしたデータは下記のように、Tab区切りと改行区切りのデータとしてクリップボードに格納されます。
このクリップボードのデータをマクロで貼り付けると以下のようになります。
注意点としては、EXCELでコピーしたデータはマクロを実行する前に一旦クリップボードが空になってしまうので、メモ帳などを経由するようにするといいと思います。
以下はVBAのコードです。（青色は私が趣味で付加したものです）
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub クリップボードのデータを可視セルのみに貼り付ける()
'Microsoft Forms 2.0 Object Library に参照設定要
'複数セルを選択した状態で実行するとアクティブセル（白抜き）が貼り付け開始位置となる
'結合セルを選択した状態で実行すると結合セルの左上セルが貼り付け開始位置となる
'結合セルに貼り付けたい場合は結合セルを選択する。もしくは結合セルの左端と同列のセルを選択する
'改行区切りで下方向に貼り付け
'Tab区切りがあれば右方向に貼り付け（右方向の非表示セルには未対応）
Dim Dobj As DataObject
Dim V As Variant 'クリップボードのデータ全体
Dim A As Variant 'その内の一行
Dim rngDest As Range
Dim R As Range
Dim i As Integer
Dim XS As Integer
Dim XP As Integer
Dim YS As Integer
Dim YP As Integer
Dim YE As Integer
If ActiveSheet.AutoFilter Is Nothing Then
MsgBox "オートフィルターが設定されていません！"
Exit Sub
End If
YP = ActiveCell.Row '現在選択しているセルの行番号を取得
XP = ActiveCell.Column '現在選択しているセルの列番号を取得
XP = XP + 1 'AutoFilter.Rangeの左端の列番号が相対的に1となるようにする
YS = ActiveCell.Worksheet.AutoFilter.Range.Row 'オートフィルターが適用される範囲の上端の行番号を取得
XS = ActiveCell.Worksheet.AutoFilter.Range.Column 'オートフィルターが適用される範囲の左端の列番号を取得
YE = ActiveCell.Worksheet.AutoFilter.Range.Rows(ActiveCell.Worksheet.AutoFilter.Range.Rows.Count).Row
'オートフィルターが適用される範囲の下端の行番号を取得
If YP < YS Or YP > YE Then
MsgBox "オートフィルター範囲外（上・下方向）には貼り付けできません！"
Exit Sub
End If
XP = XP - XS
YP = YP - YS
With ActiveCell.Worksheet.AutoFilter.Range
Set rngDest = .Columns(XP)
Set rngDest = Intersect(rngDest, rngDest.Offset(YP))
If YP + YS = YE Then '現在選択しているセルがオートフィルターが適用される範囲の下端の場合は可視セルの取得処理をパスする
Else
Set rngDest = rngDest.SpecialCells(xlCellTypeVisible) '最後に可視セルを取得するのがみそ
End If
End With
Set Dobj = New DataObject
With Dobj
.GetFromClipboard
On Error Resume Next
V = .GetText
On Error GoTo 0
End With
If Not IsEmpty(V) Then 'クリップボードからテキストが取得できた時のみ実行
V = Split(CStr(V), vbCrLf)
i = 0
For Each R In rngDest.Cells
If V(i) = "" Then '空白行がある場合のエラーを回避
A = CStr(V(i))
R.Value = A
Else
A = Split(CStr(V(i)), vbTab)
R.Resize(, UBound(A) + 1).Value = A
End If
i = i + 1
If i > UBound(V) Then Exit For
Next
Else
MsgBox "クリップボードにデータがありません！"
Exit Sub
End If
Set Dobj = Nothing
Set rngDest = Nothing
Set R = Nothing
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
上記のコードを実行してコンパイルエラーが発生する場合は？
このコードにはDataObjectという、VBAの標準にはないオブジェクトが使用されているため、実行するにはMicrosoft Forms 2.0 Object Libraryという外部ライブラリーを参照する設定を行う必要があります。つまり具体的に言うとVBEのツール→参照設定→参照からWindows\System32\FM20.DLLを選択する必要があるわけです。（FM20.DLLの保存場所はOSのバージョンによって異なる場合がありますが・・・）
選択範囲の文字を全角にする
For Each Nextでいろいろ作ってみた その５
選択範囲の文字を全角にするマクロです。セルの値が数字の場合は半角から全角に変換しても、EXCELが数値と判断して半角に戻してしまうため、頭に’（シングルクォート）を付けて強制的に文字列にしています。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub 選択範囲の文字を全角にする()
Dim myRange As Range
For Each myRange In Selection
If IsNumeric(myRange.Value) Then 'セルの値が数字であれば強制的に文字列にする
myRange.Value = "'" & StrConv(myRange.Value, vbWide)
Else
myRange.Value = StrConv(myRange.Value, vbWide)
End If
Next myRange
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
選択範囲の文字を半角にする
For Each Nextでいろいろ作ってみた その４
選択範囲の文字を半角にするマクロです。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub 選択範囲の文字を半角にする()
Dim myRange As Range
For Each myRange In Selection
myRange.Value = StrConv(myRange.Value, vbNarrow)
Next myRange
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
選択範囲のアルファベットの先頭文字を大文字にする
For Each Nextでいろいろ作ってみた その３
選択範囲のアルファベットの先頭文字を大文字にするマクロです。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub 選択範囲のアルファベットの先頭文字を大文字にする()
Dim myRange As Range
For Each myRange In Selection
myRange.Value = StrConv(myRange.Value, vbProperCase)
Next myRange
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
