ExcelVBAサンプルマクロ

ピボットテーブルの内容をセルに転記

Excelでクロス集計を行うには、ピボットテーブルを使うのが一番簡単なのですが、
ピボットテーブルって結構使いにくかったりしませんか?

データを集計したあと、うっかり関係ないところをドラッグしてしまって
表の形式が崩れたり・・・・・・。

クロス集計したデータさえ見れればOK、というときはピボットテーブルを作成した後、
セルに転記して元のピボットテーブルは削除してしまう、というのも手です。

以下は、ピボットテーブルのデータをセル範囲に転記するサンプルです。

サンプルコード



Sub ピボットテーブルの内容をセルに転記()

Dim strPivotName As String 'ピボットテーブル名
Dim DataArea As Range    'ピボットテーブルのセル範囲
Dim aryData As Variant   'データ範囲から値を取り込む2次元配列

strPivotName = "ピボット1"

With ThisWorkbook.Worksheets(1)
  '◆ピボットテーブルのデータ範囲取得
  Set DataArea = .PivotTables(strPivotName).TableRange1
  
  '◆見出し行の分セル範囲を縮める(データ範囲を1行下へずらし、1行分縮める)
  Set DataArea = DataArea.Offset(1, 0)
  Set DataArea = DataArea.Resize(DataArea.Rows.Count - 1)
  
  '◆セル範囲から2次元配列作成
  aryData = DataArea
  
  '◆セル範囲に転記&罫線設定
  DataArea.Offset(10, 0) = aryData
  DataArea.Offset(10, 0).Borders.LineStyle = True
  
  '◆元のピボットテーブルを削除
  .PivotTables(strPivotName).TableRange1.Clear
End With

End Sub


使用例


先にピボットテーブルを作っておきます。名前は「ピボット1」としました。
ピボットテーブルの内容をセルに転記01

実行後はこんな感じ。
ピボットテーブルの内容をセルに転記02

サンプルということで、転記する表の位置はやっつけですが、
新規シートにピボットテーブルを一時作成し配列に取り込んだあと、
ピボットテーブルのシートを削除としてもいいと思います。
レコードセットからピボットテーブルを作成するなどと組み合わせてもいいですね。

マクロ解説


ピボットテーブルのデータ範囲は、PivotTableオブジェクトの
TableRange1プロパティを参照します。
ちなみに、TableRange2プロパティもあります。
違いは、
・TabelRange1プロパティ→ページフィールドは含まれない。
・TabelRange2プロパティ→ページフィールドも含む。
らしい。(ヘルプより)

Variant型の変数にセル範囲を指定すると、セル範囲から2次元配列を作成します。

TableRange1プロパティはRangeオブジェクトを返すので、そのまま
「Variant型変数 = TableRange1プロパティ」として2次元配列を作成してもいいのですが、
ピボットテーブルの最初の行にある「合計:値」「日付」のプルダウンが邪魔なので
少しセル範囲を変えています。

Offsetプロパティは、指定した行または列分だけセル範囲をずらすプロパティです。
戻り値は変更したあとのセル範囲(Rangeオブジェクト)です。

◆Offsetプロパティ
Offset(ずらす行数、ずらす列数)
正の数を指定すれば行番号・列番号は大きくなります(下/右にずれます)
負の数を指定すれば行番号・列番号は小さくなります(上/左にずれます)

最初の状態ではデータ範囲はE1:I6ですが、Offsetで1行ずらしてE2:I7にします。
◇最初のデータ範囲(E1:I6)
ピボットテーブルの内容をセルに転記03

◇Offset後のデータ範囲(E2:I7)
ピボットテーブルの内容をセルに転記04

ただ、1行ずらすと7行目は必要ないので、1行分セル範囲を縮めないといけません。
そこで、Resizeプロパティを使います。

◆Resizeプロパティ
Resize(変更後の行数、変更後の列数)
引数を省略すると、元の行数と同じ値になります。
元データの行数はデータ範囲.Rows.Countで取得できますので、
DataArea.Resize(DataArea.Rows.Count - 1)
とすれば、元のデータから1行分縮めた範囲がセル範囲となります。(E2:I6)


ExcelVBAサンプルマクロ

ファイルをコピーする

FileCopyステートメントを使うとファイルをコピーできます。

◆FileCopyステートメント
FileCopy コピー元のファイルパス,コピー先のファイルのパス

ただし、FileCopyステートメントはコピーしようとしているファイルが使用中だと
「実行時エラー70」が発生したり、すでに同じファイルがある場合の上書き設定ができない
(必ず上書きされる)など使い勝手がちょっと悪いです。

そこで、FileSystemObjectのCopyFileメソッドを使うといいでしょう。

◆CopyFileメソッド(FileSystemObject)
FileSystemObject.CopyFile コピー元ファイル,コピー先ファイル,[上書き設定]

省略可能な引数として、第3引数にOverWrite(上書き)の設定があります。
同名のファイルがある場合、Trueにした場合は上書きし、
Falseにした場合は実行時エラー58が発生します。

サンプルコード



Sub FSOでファイルコピー()

Dim FSO As Object
Dim strFilePath As String
Dim strFileName As String

strFilePath = ThisWorkbook.Path & "¥"
strFileName = "Book1.xls"

Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.CopyFile strFilePath & strFileName, strFilePath & "Copy1.xls", True

End Sub



ExcelVBAサンプルマクロ

オートフィルターがかかっていればすべてのデータを表示

フィルターで抽出した状態から全表示するにはShowAllDataメソッドを
使いますが、オートフィルターがかかっていない時に実行すると
「実行時エラー'1004':WorkSheetクラスのShowAllDataメソッドが失敗しました」が発生します。

そこで、事前にFilterModeプロパティでオートフィルターがかかっているか判定する必要があります。

サンプルコード



Sub すべてのデータを表示()

With ThisWorkbook.Worksheets(1)
 If .FilterMode = True Then
  .ShowAllData
 End If
End With

End Sub


ExcelVBAサンプルマクロ

入力規則に合ったデータが入力されているか確認する

入力規則ではユーザーが入力できる値を制限する機能ですが、
コピーで貼り付けた場合は、入力規則外のデータも貼付けできてしまいます。

そのため、入力規則をかけていても、入力規則に合ったデータが
入力されているかどうかチェックする必要があります。

入力規則に合ったデータが入力されているかどうかは
ValidationオブジェクトのValueプロパティの値でわかります。

入力規則がかかっていない、もしくは入力規則に合う場合はTrue、
入力規則に合わない場合はFalseとなります。

サンプルコード



Sub 入力規則チェック()

Dim objcell As Range

For Each objcell In ThisWorkbook.Worksheets(1).Range("A1:B10")
 If objcell.Validation.Value = False Then
  MsgBox objcell.Address(False, False) & "は入力規則に合っていません。"
 End If
 
Next objcell

End Sub


ExcelVBAサンプルマクロ

保存確認メッセージを自作する

VBAでSaveAsメソッドを実行した時、すでに同じ名前のファイルがあると
自動的にダイアログが表示されますが、「いいえ」や「キャンセル」を押すと「実行時エラー'1004': 'SaveAs'メソッドは失敗しました」が出てしまいます。

このため、エラーを出さずにきちんと処理したい場合は処理を自分で組む必要があります。
まずはサンプルコードから。

サンプルコード



Sub 保存確認メッセージ()

Dim strFilePath As String
Dim strFileName As String
Dim flg As Boolean

'◆保存するパスの設定
strFilePath = ThisWorkbook.Path & "¥"

Do Until flg = True
  '◆保存するファイル名の入力
  strFileName = InputBox("ファイル名を入力してください。(拡張子不要)")

  If strFileName = "" Then
    MsgBox "保存をキャンセルします。"
    Exit Sub
  End If

  '◆拡張子がなければつける
  If Right$(strFileName, 4) <> ".xls" Then
    strFileName = strFileName & ".xls"
  End If

  '◆ファイルに使えない文字が入っているかチェック
  If strFileName Like "*[¥,/,"""",:,<,>,?,*,|]*" Then
    MsgBox "ファイル名に使えない記号が含まれています。"
  Else
    '◆開いているかチェック
    If fncBookOpen(strFileName) = False Then
      '◆入力したファイル名が保存先にあるかチェック
      If Dir(strFilePath & strFileName) = "" Then
        flg = True
      Else
        If MsgBox(strFileName & "はすでに存在します。上書きしますか?", vbYesNo + vbDefaultButton2) = vbYes Then
          Application.DisplayAlerts = False
          flg = True
        End If
      End If
    End If
  End If
Loop

ThisWorkbook.SaveAs strFilePath & strFileName

End Sub


Public Function fncBookOpen(strFileName As String) As Boolean

'◆ファイルが開いているかチェック
'  (開いている→True、開いていない→False)

On Error GoTo NotOpen

Workbooks(strFileName).Activate

'◆開いている場合
If ThisWorkbook.Name <> strFileName Then
  If MsgBox("すでに同じ名前のファイルが開いています。開いているファイルを閉じて、" & vbCrLf & _
    "このファイルを「 " & strFileName & "」という名前で保存しますか?", vbYesNo) = vbYes Then
      Workbooks(strFileName).Close
  Else
    fncBookOpen = True
  End If
End If

NotOpen:  '◆開いていない場合
ThisWorkbook.Activate

End Function

まじめに処理しようと思うとコードが長くなりますが、
「IFステートメント」「Do...Loopステートメント」などの基本的なものしか使っていません。

条件分岐がややこしい場合は、フローチャートで考えてみるとわかりやすくなります。
ファイル保存のフローチャート

ファイル名を入力させるテキストボックスはInputBox関数で表示します。
キャンセルをした場合は""が返るので、""の場合はExit Subでプロシージャを抜けます。

次に、入力されたファイル名に拡張子をつけます。
InputBoxのメッセージには「(拡張子不要)」と表示するのですが、そう書いてあっても
拡張子まで含めて入力してしまう人が1人2人は出ることを考えて、「拡張子がなかったらつける」という形にしています。

その後はファイル名に使えない文字が入っていないか、同名のブックを開いていないか、保存先フォルダに同名のファイルがないかを
順にチェックしていきます。

長くなりそうだったので、ファイルが開いているかのチェックは
別にユーザー定義関数「fncBookOpen」を作り、本体から分けました。

チェックがOKだったら変数flgをTrueにします。
するとDo...Loopステートメントの終了条件を満たすので、繰り返し処理を抜けてファイル保存をします。


ファイルが開いているかどうかをチェックするユーザー定義関数「fncBookOpen」はまず、エラーが出た場合ラベル「NotOpen」へ
飛ぶようにOn Resume GoToステートメントを記述しておきます。

引数で指定したブックをアクティブにし、開いていなければエラーが発生します(NotOpenへ飛ぶ)

エラーが発生した場合は保存もとのブックをアクティブにして終わります。
ユーザー定義関数「fncBookOpen」の戻り値はBoolean型で、
Boolean型の初期値はFalseなのでエラーが出た場合(ブックを開いてない場合)はFalseが返ります。


エラー処理をせずにFor Each...Nextステートメントでループさせて
判定してもいいのですが、For Each...Nextステートメントで処理する場合は、
strConv関数で大文字・小文字を揃えてからファイル名を判定する必要があって面倒なので、こっちの方法を採用しました。


ただ、見てのとおり真面目に保存するファイル名を判定しようとすると
かなり面倒くさいです。
これくらい書くくらいだったら、普通にSaveAsメソッドで1行書いてしまって
操作する人がキャンセルしないように気をつける、間違えたら一度終了させて再度実行する、といった運用を徹底した方が
すっきりする・・・・・・かもしれません。

ExcelVBAサンプルマクロ

重複しないファイル名をつける

重複しないファイル名をつけて保存するマクロのサンプルコードです。

サンプルコード



Sub 重複しないファイル名をつける()

Dim strFilePath As String
Dim strFileName As String

strFilePath = ThisWorkbook.Path & "¥"
strFileName = "Book1"

Do Until Dir(strFilePath & strFileName & ".xls") = ""
  strFileName = strFileName & "_"
Loop

ThisWorkbook.SaveAs strFilePath & strFileName & ".xls"

End Sub


サンプルコード解説


Dir関数は引数で指定したファイルがあればファイル名、なければ""を返します。

あらかじめ、変数strFileNameに保存するファイル名(サンプルではBook1)を
セットしておき、Dir関数で判定。

もし同じ名前のファイルがあれば、「_」をつけるという処理を、
一致するファイル名がなくなるまで繰り返します。

最後に拡張子をつけて保存すれば完成。

サンプルコードではThisWorkbookとしていますが、
記述を変えればもちろん、他のブックでも保存可能です。


ExcelVBAサンプルマクロ

USBのパスを取得する

USBメモリのパスを取得するマクロのサンプルコードです。

サンプルコード



Sub USBチェック()

Dim FSO As Object
Dim obj As Object
Dim strDrivePath As String

Set FSO = CreateObject("Scripting.FileSystemObject")

For Each obj In FSO.Drives
  If obj.DriveType = 1 Then      '◆リムーバブルディスクの場合
    If obj.DriveLetter <> "A" Then '◆フロッピーの場合はとばす
      strDrivePath = obj.DriveLetter & ":¥"
    End If
  End If
Next

If strDrivePath <> "" Then
  MsgBox "USBドライブのパスは" & strDrivePath
Else
  MsgBox "USBメモリがありません。"
End If

Set FSO = Nothing

End Sub


FileSystemObjectのDriveTypeプロパティを調べることで、
ドライブの種類が判別できます。




種類
0 不明
1 リムーバブルディスク
2 ハードディスク
3 ネットワークドライブ
4 CD-ROMドライブ
5 RAMディスク


リムーバブルディスクでなおかつAドライブ(フロッピーディスク)ではない
パスを取得することで、USBドライブのパスを取得します。

ExcelVBAサンプルマクロ

デスクトップなどの特殊フォルダ名を取得する

デスクトップのパス名を取得したい場合、ユーザー名が入るため、
普通のやり方では取得できません。

特殊なパスを取得するには、VBAだけではできないので
WSH(Windows Script Host)というのを使います。

WSHとは、ものすごく大雑把に言ってしまうとテキストファイルに
VBAっぽいコードを書いて簡単なプログラムを実行しちゃおう、
というWindowsについている機能。

Windowsを操作するためのオブジェクトもセットになっているので、
WSHのオブジェクトを通すことで特殊フォルダのパスが取得できます。

コードはいたってシンプル。

サンプルコード



Sub 特殊フォルダ名を取得()

Dim strFileName As String

strFileName = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop") & "¥"
MsgBox strFileName

End Sub

特殊フォルダのパスはWSHのWscript.ShellオブジェクトにあるSpecialFoldersプロパティに格納されています。
インデックス番号でも指定できます。



インデックスパス
1C:¥Documents and Settings¥All Users¥デスクトップ
2C:¥Documents and Settings¥All Users¥スタート メニュー
3C:¥Documents and Settings¥All Users¥スタート メニュー¥プログラム
4C:¥Documents and Settings¥All Users¥スタート メニュー¥プログラム¥スタートアップ
5C:¥Documents and Settings¥<ユーザー名>¥デスクトップ
6C:¥Documents and Settings¥<ユーザー名>¥Application Data
7C:¥Documents and Settings¥<ユーザー名>¥PrintHood
8C:¥Documents and Settings¥<ユーザー名>¥Templates
9C:¥WINDOWS¥Fonts
10C:¥Documents and Settings¥<ユーザー名>¥NetHood
11C:¥Documents and Settings¥<ユーザー名>¥デスクトップ
12C:¥Documents and Settings¥<ユーザー名>¥スタート メニュー
13C:¥Documents and Settings¥<ユーザー名>¥SendTo
14C:¥Documents and Settings¥<ユーザー名>¥Recent
15C:¥Documents and Settings¥<ユーザー名>¥スタート メニュー¥プログラム¥スタートアップ
16C:¥Documents and Settings¥<ユーザー名>¥Favorites
17C:¥Documents and Settings¥<ユーザー名>¥My Documents
18C:¥Documents and Settings¥<ユーザー名>¥スタート メニュー¥プログラム



ExcelVBAサンプルマクロ

フォルダを選択させるダイアログを表示させる

ファイルではなく、フォルダを選択させたい時はFileDialogオブジェクトを
使います。

FileDialogオブジェクトに「msoFileDialogFolderPicker」を指定すると、
フォルダを選択させるダイアログが表示されます。

サンプルコード

]

Sub フォルダ選択()

Dim strFolderName As String

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = ThisWorkbook.Path & "¥"
  .Show
 
  If .SelectedItems.Count = 0 Then
    MsgBox "キャンセルします。"
    Exit Sub
  End If
 
  strFolderName = .SelectedItems(1)
 
End With

End Sub


ただし、この方法は2002以降だけで有効です。
2000以前のものでフォルダを選択させるダイアログを表示させるには、
WindowsAPIを使わないといけません。



ExcelVBAサンプルマクロ

フルパスをパスとファイル名に分ける

GetOpenFilenameメソッドなどでファイルを選ばせる場合、
取得できるのはファイルのフルパスになります。

ブックを操作する場合はファイル名で指定する必要があるので、
フルパスを取得した後パスとファイル名に分けておくと扱いやすいです。

サンプルコード



Sub フルパス分割()

Dim strFullPath As String
Dim strPath As String
Dim strName As String

strFullPath = Application.GetOpenFilename

If strFullPath = "False" Then
  MsgBox "キャンセル"
  Exit Sub
End If

'◆フルパスをパスとファイル名に分割
strName = Dir(strFullPath)
strPath = Replace(strFullPath, strName, "")

End Sub


Dir関数は引数で指定したファイルがあればそのファイル名を返します。
引数にフルパスを指定すれば、そのファイルのファイル名だけ抜き出せます。

ファイル名が取得できたら、あとはフルパスからファイル名部分を
""で置換するだけでパスも取得できます。


1 2 >>


Powered by Seesaa
×

この広告は1年以上新しい記事の投稿がないブログに表示されております。