（現象）
追加クエリを使用する際、
空白セルに書式設定がされていたら、
そのセルは入力済みと判断する。
↓
書式設定がされていない行から入力を開始する。
↓
既存値と新規取得値（追加クエリの結果）に間が空いてしまう。
（対処法）
一旦セル全体の書式をクリアしてから追加クエリを実行する方が良い。
例）
'追加先のシートの書式をクリアする
Sheets("既存データ").Cells.ClearFormats
'追加クエリを実行する
myRs.Open "INSERT INTO [既存データ$] SELECT * FROM [追加データ$] ;", myCn
'（更新クエリ）値を更新する
'myVの値のレコード（行）なら、CD項目はmyAに変更する
'UPDATE シート名 SET 更新する項目名 = 更新する値 WHERE 条件式
例）
myA = "'aaaa'" '更新後の値
myV = 6460000 'キーとなる値
myRs2.Open "UPDATE [データ$] SET アカサタナ = " & myA & " WHERE 郵便番号 = cstr(" & myV & ") ;", myCn2
'（追加クエリ）値を追加する
'INSERT INTO シート名 (項目名) VALUES(値)
例）
myRs2.Open "INSERT INTO [データ$] (CD,a) VALUES(49,5555) ;", myCn2
'（削除クエリ）値を削除する
'DELETEはエクセルでは対応していない！
'かわりに次のような対応の仕方がある
例）
'①対象となる値を抽出し、キーとして「削除」という文言を入れる
myRs2.Open "UPDATE [データ$] SET CD = '削除' WHERE 郵便番号 IS NULL ;", myCn2
'②削除という文言が入っているセル以外を抽出しなおす
myRs2.Open "SELECT * FROM [データ$] WHERE CD <> '削除' ;", myCn2
'myVの値のレコード（行）なら、CD項目はmyAに変更する
'UPDATE シート名 SET 更新する項目名 = 更新する値 WHERE 条件式
例）
myA = "'aaaa'" '更新後の値
myV = 6460000 'キーとなる値
myRs2.Open "UPDATE [データ$] SET アカサタナ = " & myA & " WHERE 郵便番号 = cstr(" & myV & ") ;", myCn2
'（追加クエリ）値を追加する
'INSERT INTO シート名 (項目名) VALUES(値)
例）
myRs2.Open "INSERT INTO [データ$] (CD,a) VALUES(49,5555) ;", myCn2
'（削除クエリ）値を削除する
'DELETEはエクセルでは対応していない！
'かわりに次のような対応の仕方がある
例）
'①対象となる値を抽出し、キーとして「削除」という文言を入れる
myRs2.Open "UPDATE [データ$] SET CD = '削除' WHERE 郵便番号 IS NULL ;", myCn2
'②削除という文言が入っているセル以外を抽出しなおす
myRs2.Open "SELECT * FROM [データ$] WHERE CD <> '削除' ;", myCn2
1： エクセルのシート名はFROM句の後で[ $]で囲う。
例） FROM [sheets1$]
2： エクセルでコネクションを行う際の留意点
例）
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Data Source") = ThisWorkbook.FullName ’←アドレスを入力
.Properties("Extended Properties") = "Excel 12.0" ’エクセルの場合は必ず指定する
3： 値内のワイルドカードは % を用いる。なお値はシングルコーテーションで囲う。
例） LIKE '654%'
4： JOIN句
4-1：LEFT JOIN ⇒左側の値を元に照合する
（例）
SELECT * FROM 左 LEFT JOIN 右 ON 左.項目 ＝ 右.項目
（データ） ⇒ （抽出結果）
左 右 左 右
--------------- ---------------
○1 ○1 ○1 ○1
○2 ○2
○3 ｘｘｘ抽出されないｘｘｘ
4-2：RIGHT JOIN ⇒右側の値を元に照合する
（例）
SELECT * FROM 左 RIGHT JOIN 右 ON 左.項目 ＝ 右.項目
（データ） ⇒ （抽出結果）
左 右 左 右
--------------- ---------------
○1 ○1 ○1 ○1
○2 ｘｘｘ抽出されないｘｘｘ
○3 ○3
4-3： INNER JOIN ⇒互いに一致する値のみ抽出する
（例）
SELECT * FROM 左 INNER JOIN 右 ON 左.項目 ＝ 右.項目
＜次のSQLと抽出結果は同じ＞
SELECT * FROM 左 , 右 ON 左.項目 ＝ 右.項目
（データ） ⇒ （抽出結果）
左 右 左 右
--------------- ---------------
○1 ○1 ○1 ○1
○2 ｘｘｘ抽出されないｘｘｘ
○3 ｘｘｘ抽出されないｘｘｘ
※4-1を利用して、右側にないデータを抽出することができる
（例）
SELECT * 左 LEFT JOIN 右 ON 左.項目 ＝ 右.項目 WHERE 右 IS NULL
（データ） ⇒ （抽出結果）
左 右 左 右
--------------- ---------------
○1 ○1 ｘｘｘ抽出されないｘｘｘ
○2 ○2
○3 ｘｘｘ抽出されないｘｘｘ
～～～RIGHT JOINを用いる場合は逆の結果になる～～～
（例）
SELECT * 左 RIGHT JOIN 右 ON 左.項目 ＝ 右.項目 WHERE 左 IS NULL
（データ） ⇒ （抽出結果）
左 右 左 右
--------------- ---------------
○1 ○1 ｘｘｘ抽出されないｘｘｘ
○2 ｘｘｘ抽出されないｘｘｘ
○3 ○3
例） FROM [sheets1$]
2： エクセルでコネクションを行う際の留意点
例）
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Data Source") = ThisWorkbook.FullName ’←アドレスを入力
.Properties("Extended Properties") = "Excel 12.0" ’エクセルの場合は必ず指定する
3： 値内のワイルドカードは % を用いる。なお値はシングルコーテーションで囲う。
例） LIKE '654%'
4： JOIN句
4-1：LEFT JOIN ⇒左側の値を元に照合する
（例）
SELECT * FROM 左 LEFT JOIN 右 ON 左.項目 ＝ 右.項目
（データ） ⇒ （抽出結果）
左 右 左 右
--------------- ---------------
○1 ○1 ○1 ○1
○2 ○2
○3 ｘｘｘ抽出されないｘｘｘ
4-2：RIGHT JOIN ⇒右側の値を元に照合する
（例）
SELECT * FROM 左 RIGHT JOIN 右 ON 左.項目 ＝ 右.項目
（データ） ⇒ （抽出結果）
左 右 左 右
--------------- ---------------
○1 ○1 ○1 ○1
○2 ｘｘｘ抽出されないｘｘｘ
○3 ○3
4-3： INNER JOIN ⇒互いに一致する値のみ抽出する
（例）
SELECT * FROM 左 INNER JOIN 右 ON 左.項目 ＝ 右.項目
＜次のSQLと抽出結果は同じ＞
SELECT * FROM 左 , 右 ON 左.項目 ＝ 右.項目
（データ） ⇒ （抽出結果）
左 右 左 右
--------------- ---------------
○1 ○1 ○1 ○1
○2 ｘｘｘ抽出されないｘｘｘ
○3 ｘｘｘ抽出されないｘｘｘ
※4-1を利用して、右側にないデータを抽出することができる
（例）
SELECT * 左 LEFT JOIN 右 ON 左.項目 ＝ 右.項目 WHERE 右 IS NULL
（データ） ⇒ （抽出結果）
左 右 左 右
--------------- ---------------
○1 ○1 ｘｘｘ抽出されないｘｘｘ
○2 ○2
○3 ｘｘｘ抽出されないｘｘｘ
～～～RIGHT JOINを用いる場合は逆の結果になる～～～
（例）
SELECT * 左 RIGHT JOIN 右 ON 左.項目 ＝ 右.項目 WHERE 左 IS NULL
（データ） ⇒ （抽出結果）
左 右 左 右
--------------- ---------------
○1 ○1 ｘｘｘ抽出されないｘｘｘ
○2 ｘｘｘ抽出されないｘｘｘ
○3 ○3
Sub test()
'アクセスへADOで接続して、データを抽出する
'事前に[ﾂｰﾙ]-[参照設定]より
'Microsoft ActiveX Data Objects x.x Library にチェックマークを入れておく
'画面の更新を止める
Application.ScreenUpdating = False
'↓↓↓ADO↓↓↓
Dim myCn As New ADODB.Connection
Dim myRs As New ADODB.Recordset
Dim myFile As Variant
'myFile に読み込むデータの保存先を設定する（適宜変更必要）
'（今回は設定シートのA1セルにアドレスがあるとする）
myFile = ThisWorkbook.Sheets("設定").Cells(1, 1).Value
With myCn
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Data Source") = myFile
.Open
End With
'SQL文（適宜変更必要）
'excelとは書き方が異なる(テーブル名は[ $]で囲わなくとも良い)
myRs.Open "SELECT * FROM KEN_ALL;", myCn
'データシートの...
With ThisWorkbook.Sheets("データ")
.Cells.Clear '以前抽出したデータを削除する
.Cells(2, 1).CopyFromRecordset myRs 'A2セルにSQLで抽出したデータを取り込む
End With
'メモリをクリア
myRs.Close
Set myRs = Nothing
myCn.Close
Set myCn = Nothing
'↑↑↑ADO↑↑↑
'画面の更新再開
Application.ScreenUpdating = True
MsgBox "OK"
End Sub
事前に[設定]シートに条件を設定
↓
Sheet1 に元データがある
↓
Sheet2 へデータを映して加工する
↓
Sheet3 に抽出結果を出力する
≪コード≫
'[設定]シートにある抽出条件以外のデータを抜き出す
Const myFlag As String = "不要"
Dim x As Long
Dim i As Long
Dim myFiNo As Long
Dim myStr As String
'前回設定したフィルタが残っていることを考えて二回クリアを実行する
With Sheets("Sheet2")
.Cells.Clear
.Cells.Clear
'Sheet1 を Sheet2 にコピーする
Sheets("Sheet1").Range("A1").CurrentRegion.Copy .Range("A1")
'[Sheet2]を並べ替えることでSpecialCellsを使用したときにエラーが生じにくくなる
.Range("A1").CurrentRegion.Sort Key1:=.Cells(2, myFiNo), Order1:=xlAscending, Header:=xlYes
'Sheet2の１行目のもっとも右に抽出非対称項目を設定する
x = .Range("A1").CurrentRegion.Columns.Count + 1
.Cells(1, x).Value = myFlag
'フィールド番号を把握する
i = 2
Do While .Cells(1, i).Value <> ""
If Sheets("設定").Cells(1, "A").Value = .Cells(1, i).Value Then
myFiNo = i
Exit Do
End If
i = i + 1
Loop
'[設定]シート－A列を元に不要なデータに印をつける
i = 2
Do While Sheets("設定").Cells(i, "A").Value <> ""
myStr = Sheets("設定").Cells(i, "A").Value
.Range("A1").AutoFilter Field:=myFiNo, Criteria1:=myStr
'可視セルの[非抽出]列に印をつける
.Columns(x).SpecialCells(xlVisible).Value = myFlag
i = i + 1
.AutoFilterMode = False
Loop
'[Sheet3]シートにデータをコピーする準備
Sheets("Sheet3").Cells.Clear
'[Sheet2]シ―トから[Sheet3]シートへ不要なデータ以外（必要なデータのみ）を抽出
'[設定]シート－C1～C2セルに事前に設定をしておく
.Range("A1").CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("Sheet3").Range("A1"), _
CriteriaRange:=Sheets("設定").Range("C1:C2"), _
Unique:=True
'ダミーで作った項目名を消す
Sheets("Sheet3").Cells(1, x).Clear
End With
↓
Sheet1 に元データがある
↓
Sheet2 へデータを映して加工する
↓
Sheet3 に抽出結果を出力する
≪コード≫
'[設定]シートにある抽出条件以外のデータを抜き出す
Const myFlag As String = "不要"
Dim x As Long
Dim i As Long
Dim myFiNo As Long
Dim myStr As String
'前回設定したフィルタが残っていることを考えて二回クリアを実行する
With Sheets("Sheet2")
.Cells.Clear
.Cells.Clear
'Sheet1 を Sheet2 にコピーする
Sheets("Sheet1").Range("A1").CurrentRegion.Copy .Range("A1")
'[Sheet2]を並べ替えることでSpecialCellsを使用したときにエラーが生じにくくなる
.Range("A1").CurrentRegion.Sort Key1:=.Cells(2, myFiNo), Order1:=xlAscending, Header:=xlYes
'Sheet2の１行目のもっとも右に抽出非対称項目を設定する
x = .Range("A1").CurrentRegion.Columns.Count + 1
.Cells(1, x).Value = myFlag
'フィールド番号を把握する
i = 2
Do While .Cells(1, i).Value <> ""
If Sheets("設定").Cells(1, "A").Value = .Cells(1, i).Value Then
myFiNo = i
Exit Do
End If
i = i + 1
Loop
'[設定]シート－A列を元に不要なデータに印をつける
i = 2
Do While Sheets("設定").Cells(i, "A").Value <> ""
myStr = Sheets("設定").Cells(i, "A").Value
.Range("A1").AutoFilter Field:=myFiNo, Criteria1:=myStr
'可視セルの[非抽出]列に印をつける
.Columns(x).SpecialCells(xlVisible).Value = myFlag
i = i + 1
.AutoFilterMode = False
Loop
'[Sheet3]シートにデータをコピーする準備
Sheets("Sheet3").Cells.Clear
'[Sheet2]シ―トから[Sheet3]シートへ不要なデータ以外（必要なデータのみ）を抽出
'[設定]シート－C1～C2セルに事前に設定をしておく
.Range("A1").CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("Sheet3").Range("A1"), _
CriteriaRange:=Sheets("設定").Range("C1:C2"), _
Unique:=True
'ダミーで作った項目名を消す
Sheets("Sheet3").Cells(1, x).Clear
End With
例に取り上げたコードでは
[Sheet1]シートにあるデータを
[Sheet2]シート―A1～H3セルの設定より
[Sheet2]シート―A10セルへ重複データを除いて抽出する
といった機能がある
With Worksheets("Sheet1")
.Range("A1").CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("Sheet2").Range("A10"), _
CriteriaRange:=Sheets("Sheet2").Range("A1:H3"), _
Unique:=True
End With
１：.Range("A1").CurrentRegion.AdvancedFilter
⇒データを取得する範囲
２：Action:=xlFilterCopy
⇒データをコピーで抜き出す設定
３：CopyToRange:=Sheets("Sheet2").Range("A10")
⇒抽出したデータを張り付けるセル位置
４：CriteriaRange:=Sheets("Sheet2").Range("A1:H3")
⇒抽出条件が記された範囲
５：Unique:=True
⇒重複しているデータは除く
[Sheet1]シートにあるデータを
[Sheet2]シート―A1～H3セルの設定より
[Sheet2]シート―A10セルへ重複データを除いて抽出する
といった機能がある
With Worksheets("Sheet1")
.Range("A1").CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("Sheet2").Range("A10"), _
CriteriaRange:=Sheets("Sheet2").Range("A1:H3"), _
Unique:=True
End With
１：.Range("A1").CurrentRegion.AdvancedFilter
⇒データを取得する範囲
２：Action:=xlFilterCopy
⇒データをコピーで抜き出す設定
３：CopyToRange:=Sheets("Sheet2").Range("A10")
⇒抽出したデータを張り付けるセル位置
４：CriteriaRange:=Sheets("Sheet2").Range("A1:H3")
⇒抽出条件が記された範囲
５：Unique:=True
⇒重複しているデータは除く
＜サンプル＞
’36行目で改ページを行う
Rows(36).PageBreak = xlManual
’シート内の改ページを解除する
Cells.PageBreak = xlNone
’36行目で改ページを行う
Rows(36).PageBreak = xlManual
’シート内の改ページを解除する
Cells.PageBreak = xlNone
イベントプロシージャなどとあわせて用いることで、
ActiveXのオブジェクトを自動的に整列させたり、
表示文字を随時変更することができる。
この例では
ラジオボタン
を
四行
ずつ整列させるものとする。
＜サンプル＞
'******定数の宣言*****
Const a As Integer = 4 'ラジオボタンの行数
Const myLeft As Integer = 330 '並び始めの位置（左）
Const myTop As Integer = 25 '並び始めの位置（上）
Const myHei As Integer = 20 '高さ
Const myWid As Integer = 135 '幅
Const amariWid As Integer = 20 'オブジェクトとオブジェクトの横の間隔
Const amariTop As Integer = 2 'オブジェクトとオブジェクトの縦の間隔
'*****変数の宣言*****
Dim obj As OLEObject
'取得しているラジオボタンの・・・
Dim i As Long '番号
Dim b As Long '列数
Dim c As Long '行数
'*****ラジオボタンに表示する文字を配列myValに格納する*****
'この例では「値格納」シートのセルA1より行方向へ値が記されているとする
Sheets("値格納").Activate
myVal = Range("A1").CurrentRegion.Value
'*****処理開始*****
'この例では「メイン」シートにラジオボタンが配置されているとする
Sheets("メイン").Activate
i = 2
For Each obj In ActiveSheet.OLEObjects
b = Int((i / 2) / a) '列数
c = i - 2 - 4 * b
With obj
'ラジオボタンの・・・
'大きさ
.Height = myHei
.Width = myWid
'配置位置
.Left = myLeft + myWid * b + amariWid
.Top = myTop + myHei * c + amariTop
With .Object
.Caption = myVal(i, 1) '表示
.FontWeight = 400 'フォントの太さ
.FontSize = 11 'フォントサイズ
.AutoSize = False 'サイズの自動調整を行わない
End With
End With
i = i + 1
Next
ActiveXのオブジェクトを自動的に整列させたり、
表示文字を随時変更することができる。
この例では
ラジオボタン
を
四行
ずつ整列させるものとする。
＜サンプル＞
'******定数の宣言*****
Const a As Integer = 4 'ラジオボタンの行数
Const myLeft As Integer = 330 '並び始めの位置（左）
Const myTop As Integer = 25 '並び始めの位置（上）
Const myHei As Integer = 20 '高さ
Const myWid As Integer = 135 '幅
Const amariWid As Integer = 20 'オブジェクトとオブジェクトの横の間隔
Const amariTop As Integer = 2 'オブジェクトとオブジェクトの縦の間隔
'*****変数の宣言*****
Dim obj As OLEObject
'取得しているラジオボタンの・・・
Dim i As Long '番号
Dim b As Long '列数
Dim c As Long '行数
'*****ラジオボタンに表示する文字を配列myValに格納する*****
'この例では「値格納」シートのセルA1より行方向へ値が記されているとする
Sheets("値格納").Activate
myVal = Range("A1").CurrentRegion.Value
'*****処理開始*****
'この例では「メイン」シートにラジオボタンが配置されているとする
Sheets("メイン").Activate
i = 2
For Each obj In ActiveSheet.OLEObjects
b = Int((i / 2) / a) '列数
c = i - 2 - 4 * b
With obj
'ラジオボタンの・・・
'大きさ
.Height = myHei
.Width = myWid
'配置位置
.Left = myLeft + myWid * b + amariWid
.Top = myTop + myHei * c + amariTop
With .Object
.Caption = myVal(i, 1) '表示
.FontWeight = 400 'フォントの太さ
.FontSize = 11 'フォントサイズ
.AutoSize = False 'サイズの自動調整を行わない
End With
End With
i = i + 1
Next
ファイル内のデータを一括で移動またはコピーする。
このサンプルではコピー用にしているため、
[ '操作内容は..]部分で移動に関するコードをコメントブロックしている。
移動に変更するなら、
コピー部分をコメントブロックして、
移動部分のコメントをはずすと良い。
なお、コピー元とコピー先のフォルダのアドレスは、
ﾀﾞｲｱﾛｸﾞﾎﾞｯｸｽなどで指定するように変更すると良いだろう。
＜サンプル＞
Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'動作方法を指定
Type SHFILEOPSTRUCT
myHnd As Long 'ダイアログボックスの親ウィンドウのハンドル
myFunc As Long '操作内容を指定する
fileFrom As String '操作元のファイル名、ディレクトリ名
fileTo As String '操作先のファイル名、ディレクトリ名
End Type
'操作内容を指定
Public Const FO_MOVE = &H1& '移動
Public Const FO_COPY = &H2& 'コピー
Sub ファイルを一括にコピーか移動する()
Dim myCopy As SHFILEOPSTRUCT
Dim c As Long
Dim myClass As String 'クラス名
'Excelのクラス名
myClass = "XLMAIN"
With myCopy
'ダイアログボックスの親ウィンドウのハンドル
.myHnd = FindWindow(myClass, Application.Caption)
'操作内容は...
.myFunc = FO_COPY '「コピー」
' .myFunc = FO_MOVE '「移動」
'コピー元のファイルアドレスを指定
.fileFrom = "C:\Documents and Settings\***\デスクトップ\test1\読み込み元" ’←アドレスを入力すること
'コピー先のファイアドレスルを指定
.fileTo = "C:\Documents and Settings\***\デスクトップ\test1\test01" ’←アドレスを入力すること
End With
'実行する
c = SHFileOperation(myCopy)
End Sub
このサンプルではコピー用にしているため、
[ '操作内容は..]部分で移動に関するコードをコメントブロックしている。
移動に変更するなら、
コピー部分をコメントブロックして、
移動部分のコメントをはずすと良い。
なお、コピー元とコピー先のフォルダのアドレスは、
ﾀﾞｲｱﾛｸﾞﾎﾞｯｸｽなどで指定するように変更すると良いだろう。
＜サンプル＞
Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'動作方法を指定
Type SHFILEOPSTRUCT
myHnd As Long 'ダイアログボックスの親ウィンドウのハンドル
myFunc As Long '操作内容を指定する
fileFrom As String '操作元のファイル名、ディレクトリ名
fileTo As String '操作先のファイル名、ディレクトリ名
End Type
'操作内容を指定
Public Const FO_MOVE = &H1& '移動
Public Const FO_COPY = &H2& 'コピー
Sub ファイルを一括にコピーか移動する()
Dim myCopy As SHFILEOPSTRUCT
Dim c As Long
Dim myClass As String 'クラス名
'Excelのクラス名
myClass = "XLMAIN"
With myCopy
'ダイアログボックスの親ウィンドウのハンドル
.myHnd = FindWindow(myClass, Application.Caption)
'操作内容は...
.myFunc = FO_COPY '「コピー」
' .myFunc = FO_MOVE '「移動」
'コピー元のファイルアドレスを指定
.fileFrom = "C:\Documents and Settings\***\デスクトップ\test1\読み込み元" ’←アドレスを入力すること
'コピー先のファイアドレスルを指定
.fileTo = "C:\Documents and Settings\***\デスクトップ\test1\test01" ’←アドレスを入力すること
End With
'実行する
c = SHFileOperation(myCopy)
End Sub
特定の値のみを抽出し、
そのほかの値は非表示にする。
なお、myVal変数を配列にして、
二重ループにすると、
複数の値が抽出できる。
＜サンプル＞
Sub B_特定の値のみ選択する()
Application.ScreenUpdating = False
Dim PT As String
Dim PF As String
Dim myVal As Variant
PT = "ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ"
PF = "年月日"
myVal = "2009/1/1"
With ActiveSheet.PivotTables(PT).PivotFields(PF)
'非表示の時は実行しない
If .Orientation = 0 Then
Exit Sub
End If
'選択開始
On Error Resume Next
i = 1
Do While i < .PivotItems.Count + 1
If .PivotItems(i).Value <> myVal Then
.PivotItems(i).Visible = False
ElseIf .PivotItems(i).Value = myVal Then
.PivotItems(i).Visible = True
End If
i = i + 1
Loop
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub
そのほかの値は非表示にする。
なお、myVal変数を配列にして、
二重ループにすると、
複数の値が抽出できる。
＜サンプル＞
Sub B_特定の値のみ選択する()
Application.ScreenUpdating = False
Dim PT As String
Dim PF As String
Dim myVal As Variant
PT = "ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ"
PF = "年月日"
myVal = "2009/1/1"
With ActiveSheet.PivotTables(PT).PivotFields(PF)
'非表示の時は実行しない
If .Orientation = 0 Then
Exit Sub
End If
'選択開始
On Error Resume Next
i = 1
Do While i < .PivotItems.Count + 1
If .PivotItems(i).Value <> myVal Then
.PivotItems(i).Visible = False
ElseIf .PivotItems(i).Value = myVal Then
.PivotItems(i).Visible = True
End If
i = i + 1
Loop
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub