ピボットテーブル用の元データに年度・四半期・月フィールドを作成する
ピボットテーブルを使用すると、大量のデータを様々な角度から集計できて便利なのですが･･････、ピボットテーブルには何故か「年度」というグループ分け機能が搭載されていないため、年度ごとに集計を行う場合には非常に不便です。
例えば、集計や累計などは年単位で区切られるので1月～12月の集計・累計となり、次の1月1日からは新たな集計・累計の始まりとなります。（年度ごとの集計・累計にならない）
また、四半期ごとにグループ分けを行うと、1月が四半期の始まり（第1四半期）となるのも不便です。
これを解決する方法は、いくつかありますか、私はピボットテーブルの元データに年度・四半期・月フィールドを追加するのが一番手っ取り早いと思います（既に他の多くのサイト様でも同じように紹介されていますが･･････）
年度・四半期・月フィールドは下記のような数式で作成できます。
年度フィールド
=IF(D2="","",IF(MONTH(D2)<=3,YEAR(D2)-1&"年度",YEAR(D2)&"年度"))
四半期フィールド
=IF(D2="","",IF(MONTH(D2)<=3,"第4四半期",IF(MONTH(D2)<=6,"第1四半期",IF(MONTH(D2)<=9,"第2四半期","第3四半期"))))
月フィールド
=IF(D2="","",MONTH(D2)&"月")
※D2の部分は相対参照によって異なります
そして、ピボットテーブルを作成する際、元の「日付」フィールドは使用せずに、新たに作成した「年度」「四半期」「月」フィールドを使用しましょう。
下記のようなピボットテーブルに生まれ変わります。
4月～3月を一つの年度とし、四半期の始まりが4月になります（集計も年度単位となっています）
しかーし！
ここまでは他のサイト様が紹介している内容とさほど変わりはなく、VBAの勉強を始めてみたを謳い文句にしている当ブログの名折れとなってしまうので、年度・四半期・月フィールドを瞬時に作成するコードを作成してみました。
ピボットテーブルの元データの日付フィールドの1セルを選択した状態でマクロを実行して下さい。
日付フィールドの左側に年度・四半期・月フィールドが自動作成されます。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub ピボットテーブル用年度四半期月フィールド作成()
'日付データが入ったフィールドの１セルを選択（どれでも良い）して実行
Dim X As Long
Dim YS As Long
Dim YE As Long
If TypeName(ActiveCell.Value) = "Date" Then
X = ActiveCell.Column
YS = ActiveCell.CurrentRegion.Row
YE = ActiveCell.CurrentRegion.Rows(ActiveCell.CurrentRegion.Rows.Count).Row
Range(Columns(ActiveCell.Column), Columns(ActiveCell.Column + 2)).Insert xlShiftToRight, _
xlFormatFromLeftOrAbove
Cells(YS, X).Value = "年度"
Range(Cells(YS + 1, X), Cells(YE, X)).FormulaR1C1 = _
"=IF(RC[3]="""","""",IF(MONTH(RC[3])<=3,YEAR(RC[3])-1&""年度"",YEAR(RC[3])&""年度""))"
Cells(YS, X + 1).Value = "四半期"
Range(Cells(YS + 1, X + 1), Cells(YE, X + 1)).FormulaR1C1 = _
"=IF(RC[2]="""","""",IF(MONTH(RC[2])<=3,""第4四半期"",IF(MONTH(RC[2])<=6,""第1四半期"",IF(MONTH(RC[2])<=9,""第2四半期"",""第3四半期""))))"
Cells(YS, X + 2).Value = "月"
Range(Cells(YS + 1, X + 2), Cells(YE, X + 2)).FormulaR1C1 = _
"=IF(RC[1]="""","""",MONTH(RC[1])&""月"")"
Else
MsgBox "日付データの入ったセルを選択して下さい"
End If
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
マクロをクイックアクセスツールバーに登録する
今回はマクロをクイックアクセスツールバーに登録してみたいと思います。クイックアクセスツールバーを編集するには･･････
リボンのタブ内で右クリックし「クイックアクセスツールバーのユーザー設定」を選択します。（ファイル－オプション－クイックアクセスツールバーのユーザー設定でも同様です）
クイックアクセスツールバーのユーザー設定画面を開いたら、
１．コマンドの選択で「マクロ」を選びます
２．現在開いているブックや個人用マクロブックに登録されているマクロが一覧表示されるので、必要なものを選択し「追加」を押します。すべてのドキュメントに適用（既定）欄にマクロが追加されるので、これを必要なだけ繰り返します。
３．マクロの追加が終わったら、ＯＫを押して設定を終了します。
クイックアクセスツールバーに登録したマクロが表示されます。
･･････が、どれが何のマクロか分かりにくい為、使用頻度の高いもののみ2～3個の登録に留めるのが良いかと個人的には思います。
マクロをリボンに登録する
今回はマクロをリボンに登録してみたいと思います。リボンを編集するには･･････
リボンのタブ内のどこでもいいので右クリックして「リボンのユーザー設定」をクリックします。（ファイル－オプション－リボンのユーザー設定からでも同じように入れます）
リボンのユーザー設定画面を開いたら、
１．メインタブを選択します
２．新しいタブを作成（今回は名前を「マクロ」とします）
３．新しいグループを作成
４．コマンドの選択で「マクロ」を選びます
５．現在開いているブックや個人用マクロブックに登録されているマクロが一覧表示されますので、必要なものを選んで「追加」を押します。新しいグループ（ユーザー設定）にマクロが追加されるので、これを必要なだけ繰り返します。
６．マクロの追加が終わったら、ＯＫを押して設定を終了します。
マクロというタブが追加され、その中に追加したマクロのボタンがズラリと並んでいます。
･･････が、個人用マクロブックから登録したものはPERSONAL.XLSB!○○○という長ったらしい名前が表示されるため、このままではとても見づらいです。なので、分かりやすい名前に変更したいと思います。
再度、リボンのユーザー設定画面を開き
１．登録したマクロを選択し
２．「名前の変更」をクリックします。
３．自分が分かりやすい名前に変更しましょう。お好みでアイコンも変更できます（私は変更しない派です）
４．名前の変更がすべて終わったら、ＯＫをクリックして設定を終了します。
これで、かなり見やすくなったと思うのですが、どうでしょうか？
次回はクイックアクセスツールバーへマクロを登録してみたいと思います。
クリップボードのデータを結合セルへ貼り付ける
通常、クリップボードのデータを結合セルに貼り付けようとすると･･････
このように、「この操作は結合したセルには行えません」等のエラーメッセージが表示され、貼り付けることができません。
そのようなモヤモヤを解消し、ストレスなく仕事を行うために今回のマクロを作ってみました。
下記のようなクリップボードのデータを･･････
このように、結合セルに貼り付けることができます。
ちなみに、結合セルと単一セルが混在していても、貼り付けできます。
ついでに可視セルのみに貼り付ける機能も追加しました。（画面上非表示のセルには貼り付けしません）
今回のマクロを使用するには、事前にVBEからMicrosoft Forms 2.0 Object Libraryを参照設定する必要があります。
（ツール→参照設定→参照からWindows\System32\FM20.DLLを選択）
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub クリップボードのデータを結合セルへ貼り付け()
'Microsoft Forms 2.0 Object Libraryを参照設定して下さい
Dim Dobj As DataObject
Dim V As Variant
Dim i As Integer
Dim Y As Integer
Dim X As Integer
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
Y = ActiveCell.Row
X = ActiveCell.Column
Do While i <= UBound(V)
If Cells(Y, X).Address = Cells(Y, X).MergeArea(1).Address _
And Rows(Y).Hidden = False Then
A = CStr(V(i))
Cells(Y, X).Value = A
Y = Y + 1
i = i + 1
Else
Y = Y + 1
End If
Loop
Else
MsgBox "クリップボードにデータがありません！"
End If
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
下記のマクロも合わせて使うとより効果的です。
左からn文字目の文字を置換する
左から数えて、n文字目からx文字分を、指定した文字列に置換するマクロを作ってみました。
例えば、下の画像では4文字目から3文字分を顔文字に置換してみます。
文字ではなく空白を指定した場合は、4文字目から3文字分が削除されます。
4文字目から0文字分とした場合は、4文字目の左側に指定した文字列が「挿入」されます。
応用として、先頭や末尾に文字を追加することもできます。
とてもとっつきにくいですが、色々やってみて試して見て下さい。（個人的にはわりと便利だと自負してます･･････笑）
なお、VBA関数ではなくワークシート関数のほうのReplaceを使用して作成しています。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub 左からn文字目の文字を置換する()
Dim myRange As Range
Dim ns As Integer
Dim ne As Integer
Dim tm As String
ns = InputBox("左から何文字目を置換開始位置にしますか？")
ne = InputBox("開始位置から何文字置換しますか？" _
& vbCrLf & "※文字を挿入する場合は0を入力下さい。" _
& vbCrLf & " 開始位置の左側に挿入されます。")
tm = InputBox("置換または挿入する文字を入力して下さい。" _
& vbCrLf & "※空白のままOKにすると、開始位置から" _
& vbCrLf & " 指定文字数が削除（空白に置換）されます。")
For Each myRange In Selection.SpecialCells(xlCellTypeVisible)
If myRange.Value <> "" And TypeName(myRange.Value) <> "Date" Then 'セルの値が空白,日付の場合は処理をしない
myRange.Value = Application.WorksheetFunction.Replace(myRange.Value, ns, ne, tm)
End If
Next myRange
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
結合セルのデータを単一セルのデータと同じようにクリップボードに格納する
下の画像のような結合セルをコピーしてメモ帳などに貼り付けると・・・
このように、意図しない改行やTabがクリップボードに格納されていることが分かります。
これは、結合セルが複数セルで構成されているからであり、画像の例であれば一つの結合セルに9個のセルが含まれていることになります。9個のセルのうち値が入っているのは左上のセルのみで、残りの8個のセルは空っぽです。結合セルをコピーすると値に加えて9セル分のTab区切りと改行区切りがクリップボードに格納されてしまうのです。
しかし･･････、結合セルを一つのセルのようにコピーしたいと思うのが人情ではないでしょうか？
ということで今回のマクロを組んでみました。結合セルを選択し通常の「コピー」ではなく今回のマクロを実行した場合は下のようにクリップボードに格納されます。
このように余分な改行やTabのない形でクリップボードに格納することができます。
その他、今回のマクロに下記の特徴があります。
・選択範囲の可視セルの値のみクリップボードに格納します
・選択したセルの順にクリップボードに格納されます
・セル内で改行がある場合の改行（改行コード：LF）もクリップボードに格納します。貼り付けの際にセル内改行を再現するには別途マクロを使う必要があります。今回のマクロと本記事末尾のリンク先にあるマクロを合わせて使うとより効果的です。
・単一セルでも問題なくクリップボードに格納されます
今回のマクロを使用するには、事前にVBEからMicrosoft Forms 2.0 Object Libraryを参照設定する必要があります。
（ツール→参照設定→参照からWindows\System32\FM20.DLLを選択）
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub 選択範囲のデータを改行区切りでクリップボードに格納()
'Microsoft Forms 2.0 Object Libraryを参照設定して下さい
Dim myRange As Range
Dim V As String
For Each myRange In Selection.SpecialCells(xlCellTypeVisible) '可視セルのみに処理を行う
If myRange.Address = myRange.MergeArea(1).Address Then '結合セルの場合は左上の値のみ取り出す
V = V & myRange.Value & vbCrLf
End If
Next myRange
V = Left(V, Len(V) - 2) '最終行の改行区切りを取り除く（CrLfは2文字）
With New MSForms.DataObject
.SetText V '変数の値をDataObjectに格納する
.PutInClipboard 'DataObjectのデータをクリップボードに格納する
End With
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
セル内改行を再現し、かつ結合セルにも貼り付けできるマクロ
余分な空白を削除する
Trim関数を使って、セル内の文字列の前後にある空白を一括で削除します（意図的に入れた空白も削除するので注意）。文字列と文字列の間にある空白は削除しません。使用方法としては余分な空白を削除したいセルを選択（複数選択可）した状態でマクロを実行して下さい。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub 余分な空白を削除()
Dim myRange As Range
For Each myRange In Selection.SpecialCells(xlCellTypeVisible)
If myRange.Value <> "" And TypeName(myRange.Value) <> "Date" Then 'セルの値が空白,日付の場合は処理をしない
myRange.Value = Trim(myRange.Value)
End If
Next myRange
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
