ループを使ってピボットテーブルのフィールドを全て選択する。
実行速度は遅い傾向にあるが、
sendkeysを用いるのと比べて、
動作は安定していると言えるだろう。
＜サンプル＞
Dim PT As String
Dim PF As String
PT = "ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ" ’ピボットテーブル名
PF = "月" ’フィールドリスト名
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
.PivotItems(i).Visible = True
i = i + 1
Loop
On Error GoTo 0
End With
全て選択するにはループを用いる方法もあるが、
項目数が多い場合は処理速度が著しく遅くなる場合がある。
このため、Excel 2002以降で使用可能なフィールドリストの（全て選択する）を
sendkeysより実行することとする。
＜サンプル＞
Sub B_実行()
'Excel 2002（Application.Versionが10）より前はこの機能はないので実行しない
If Int(Application.Version) < 10 Then
Exit Sub
Else
Call フィールド全て表示("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ名", "フィールド名") 'ピボットテーブルの名前,フィールドの名前
End If
End Sub
Private Sub フィールド全て表示(PT As String, PF As String)
With ActiveSheet.PivotTables(PT).PivotFields(PF)
'非表示の時は実行しない
Select Case .Orientation
Case 0
Exit Sub
Case Else
End Select
'既にピボットフィールドを全て選択している場合は実行しない
If .PivotItems.Count = .VisibleItems.Count Then
Exit Sub
End If
'ラベルを選択する
.LabelRange.Select
'sendkeysを用いてピボットフォールドを設定する
'******動作結果を見て適宜sendkeyの入力方法を変えてみる方がよい******
'＜＜＜全て選択する＞＞＞
With Application
.SendKeys "%{DOWN}" 'Alt + ↓ でフィールドの一覧を表示する
.SendKeys "{UP}"
.SendKeys "% " 'Alt + space でチェックマークをつける
.SendKeys "{ENTER}"
.SendKeys "{TAB}"
.SendKeys " "
.SendKeys "{ENTER}"
End With
End With
End Sub
項目数が多い場合は処理速度が著しく遅くなる場合がある。
このため、Excel 2002以降で使用可能なフィールドリストの（全て選択する）を
sendkeysより実行することとする。
＜サンプル＞
Sub B_実行()
'Excel 2002（Application.Versionが10）より前はこの機能はないので実行しない
If Int(Application.Version) < 10 Then
Exit Sub
Else
Call フィールド全て表示("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ名", "フィールド名") 'ピボットテーブルの名前,フィールドの名前
End If
End Sub
Private Sub フィールド全て表示(PT As String, PF As String)
With ActiveSheet.PivotTables(PT).PivotFields(PF)
'非表示の時は実行しない
Select Case .Orientation
Case 0
Exit Sub
Case Else
End Select
'既にピボットフィールドを全て選択している場合は実行しない
If .PivotItems.Count = .VisibleItems.Count Then
Exit Sub
End If
'ラベルを選択する
.LabelRange.Select
'sendkeysを用いてピボットフォールドを設定する
'******動作結果を見て適宜sendkeyの入力方法を変えてみる方がよい******
'＜＜＜全て選択する＞＞＞
With Application
.SendKeys "%{DOWN}" 'Alt + ↓ でフィールドの一覧を表示する
.SendKeys "{UP}"
.SendKeys "% " 'Alt + space でチェックマークをつける
.SendKeys "{ENTER}"
.SendKeys "{TAB}"
.SendKeys " "
.SendKeys "{ENTER}"
End With
End With
End Sub
Dim WBK As Workbook ' 各ブック名
Dim bookName As String ' 自ブック名
Set WBK = ThisWorkbook ' 自ブック
bookName = WBK.Name ' 自ブック名
For Each WBK In Workbooks
' 自ブック以外を取り込む
If WBK.Name <> bookName Then
Debug.Print " 《パス名》" & WBK.Path _
& " 《ブック名》" & WBK.Name _
& " 《シート名》" & WBK.ActiveSheet.Name
End If
Next WBK
' 自ブックをアクティブにする
ThisWorkbook.Activate
Dim bookName As String ' 自ブック名
Set WBK = ThisWorkbook ' 自ブック
bookName = WBK.Name ' 自ブック名
For Each WBK In Workbooks
' 自ブック以外を取り込む
If WBK.Name <> bookName Then
Debug.Print " 《パス名》" & WBK.Path _
& " 《ブック名》" & WBK.Name _
& " 《シート名》" & WBK.ActiveSheet.Name
End If
Next WBK
' 自ブックをアクティブにする
ThisWorkbook.Activate
ADOを使ったり、SQLで抽出したデータは
CopyFromRecordset を使うと高速でシートに取り込むことができる。
ただしフィールド（項目）は取り込めないので注意する。
＜サンプル＞
Dim rs As ADODB.Recordset
'レコードセットを開く
Set rs = New ADODB.Recordset
'レコードをA2セルへ貼り付ける
Range("A2").CopyFromRecordset rs
CopyFromRecordset を使うと高速でシートに取り込むことができる。
ただしフィールド（項目）は取り込めないので注意する。
＜サンプル＞
Dim rs As ADODB.Recordset
'レコードセットを開く
Set rs = New ADODB.Recordset
'レコードをA2セルへ貼り付ける
Range("A2").CopyFromRecordset rs
SQLで具体的なレコードを指定するときはシングルコーテーションで囲う必要がある。
例）あるシートのデータに書かれた担当者フィールドから「山田」の物を抽出する
Select * Where [$シート名].[担当者] '山田'
ただし数字の場合はシングルコーテーションを用いない
例）あるシートのデータに書かれた売上フィールドから「10000」以上の物を抽出する
Select * Where [$シート名].[売上] >= 10000
例）あるシートのデータに書かれた担当者フィールドから「山田」の物を抽出する
Select * Where [$シート名].[担当者] '山田'
ただし数字の場合はシングルコーテーションを用いない
例）あるシートのデータに書かれた売上フィールドから「10000」以上の物を抽出する
Select * Where [$シート名].[売上] >= 10000
[*****操作する場所*****]にコードなどを入力して、
サブフォームに検索結果を抽出する。
以下、作成手順を記す。
①：テーブルを作成する
↓↓↓↓↓↓
②：クエリを作成する。
このクエリには抽出条件を明記しておく
例1）完全一致の場合
[Forms]![*****フォーム名*****]![*****操作する場所*****]
例2）一部一致の場合
Like "*" & [Forms]![*****フォーム名*****]![*****操作する場所*****] & "*"
↓↓↓↓↓↓
③：フォームを作成する。
②のクエリを用いてサブフォームを作成する。
（②で指定した[*****操作する場所*****]を作成する）
↓↓↓↓↓↓
④：③のフォームにVBAで次のコードを入力して、
フォームを読み込んだ場合に更新するようにする。
サブフォームに検索結果を抽出する。
以下、作成手順を記す。
①：テーブルを作成する
↓↓↓↓↓↓
②：クエリを作成する。
このクエリには抽出条件を明記しておく
例1）完全一致の場合
[Forms]![*****フォーム名*****]![*****操作する場所*****]
例2）一部一致の場合
Like "*" & [Forms]![*****フォーム名*****]![*****操作する場所*****] & "*"
↓↓↓↓↓↓
③：フォームを作成する。
②のクエリを用いてサブフォームを作成する。
（②で指定した[*****操作する場所*****]を作成する）
↓↓↓↓↓↓
④：③のフォームにVBAで次のコードを入力して、
フォームを読み込んだ場合に更新するようにする。
Private Sub Form_Load()
Me.Recalc
End Sub
↓↓↓↓↓↓
⑤：③で作成したフォーム（②で指定した[*****操作する場所*****]）に値が入力された場合、
フォームを更新する設定をする為、
VBAで次のコードを入力する。
Private Sub [*****操作する場所*****]_AfterUpdate()
Me.Recalc
End Sub
ｱﾄﾞﾚｽを\で区切るコードを記載する。
これとフォルダ操作関係のコードと併用することも可能。
＜サンプル＞
'セルA1より上から順に分割したいｱﾄﾞﾚｽを入力する
Sub アドレス分割()
Dim myPath As String
Dim buf As String
Dim i As Long
Dim x As Long
For i = 1 To Range("A1").CurrentRegion.Rows.Count
x = 2 '分割したｱﾄﾞﾚｽを書き込み始める位置
myPath = Cells(i, "A").Value
buf = myPath
Cells(i, x).Value = Left(buf, InStr(buf, "\") - 1)
Do While InStr(buf, "\") <> 0
x = x + 1
'残りの文字を取得する
buf = Mid(buf, InStr(buf, "\") + 1, Len(buf))
'分割する必要があるか
If InStr(buf, "\") = 0 Then
'残り部分のみ書き込む
Cells(i, x).Value = buf
'→次の行に移動するにあたり初期値を設定しなおす
x = 2
Else
'文字のはじめから￥まで入力する
Cells(i, x).Value = Left(buf, InStr(buf, "\") - 1)
End If
Loop
Next i
MsgBox "処理が終わりました"
End Sub
これとフォルダ操作関係のコードと併用することも可能。
入力例：実行前～～～A列に1行目からｱﾄﾞﾚｽを入力している
↓↓↓↓↓↓ 実行後 ↓↓↓↓↓↓
分割されたｱﾄﾞﾚｽがB列より記載される
＜サンプル＞
'セルA1より上から順に分割したいｱﾄﾞﾚｽを入力する
Sub アドレス分割()
Dim myPath As String
Dim buf As String
Dim i As Long
Dim x As Long
For i = 1 To Range("A1").CurrentRegion.Rows.Count
x = 2 '分割したｱﾄﾞﾚｽを書き込み始める位置
myPath = Cells(i, "A").Value
buf = myPath
Cells(i, x).Value = Left(buf, InStr(buf, "\") - 1)
Do While InStr(buf, "\") <> 0
x = x + 1
'残りの文字を取得する
buf = Mid(buf, InStr(buf, "\") + 1, Len(buf))
'分割する必要があるか
If InStr(buf, "\") = 0 Then
'残り部分のみ書き込む
Cells(i, x).Value = buf
'→次の行に移動するにあたり初期値を設定しなおす
x = 2
Else
'文字のはじめから￥まで入力する
Cells(i, x).Value = Left(buf, InStr(buf, "\") - 1)
End If
Loop
Next i
MsgBox "処理が終わりました"
End Sub
エクセルに入力されたｱﾄﾞﾚｽを取得してファイルを開く。
実行にあたっては下図のような表をあらかじめ作成しており、
かつフォルダは既に存在するものとする。
'フォルダは既に存在していると仮定する
'→存在しない場合は最深の階層から右へ三つのセルへエラーを表記する
Dim FolPath As String
Dim c As Long
Dim i As Long '処理を行っている階層の位置
Dim x As Long
Const goA As String = "A4" 'ディレクトリの最上層が書かれたセル位置
Const InGyo As Long = 4 '処理を始める行（二回目以降の処理は五行目から行う）
Sub 一括でフォルダを開く()
Dim R As Long
Dim myLink() As String '出力したことのあるｱﾄﾞﾚｽを格納する
ReDim Preserve myLink(0)
Dim co As Long
Dim n As Long '処理を行っているフォルダ
'二回目（5行目）以降で使用
'～子ディレクトリがない→ループから抜ける
'1回目のfalse ： 親ディレクトリの空白取得中
'true ： 空白ではない
'2回目のfalse ： 再度空白になった→ループから抜ける
Dim chF As Boolean
R = Range(goA).CurrentRegion.Rows.Count 'ディレクトリの最大数
c = Range(goA).CurrentRegion.Columns.Count '階層の深さ
'～～～4行目のディレクトリを構築する
n = InGyo '行を取得
'-1:パスを取得する
'一旦、FolPathを空白にする
FolPath = ""
x = n
For i = 1 To c '列を取得
Call GetFolPath
Next i
'-2:ファイルを開く
Call OpenFolPath
' '～～～5行目以降の処理を行う
For n = InGyo + 1 To 3 + R
'フラグを初期値にする
chF = False
'一旦、FolPathを空白にする
FolPath = ""
'浅い階層から深い階層へアドレスを読み進める
For i = 1 To c
'-0：変数ｘ = FolPathへ代入するｱﾄﾞﾚｽ（列数）
x = n '
If Cells(n, i).Value = "" Then
'空白の場合・・・
'1：chFがtrue→次の行に移動
If chF = True Then
Exit For
End If
'2:chFがfalse→上の列を読み込む(最大InGyo-1行目まで）
Do While Cells(x, i).Value = ""
If x = InGyo - 1 Then
'読み込み始めの行InGyoよりも上の行になったら処理を中止する
Exit Do
Else
x = x - 1
End If
Loop
ElseIf Cells(n, i).Value <> "" Then
'空白でない場合はその値をFolPathへ
chF = True
End If
'-1:パスを取得する
Call GetFolPath
Next i
'ファイルを開く
Call OpenFolPath
Next n
MsgBox "処理が完了しました"
End Sub
Private Sub GetFolPath()
If FolPath = "" Then
'一番上の階層
FolPath = Cells(x, i).Value
ElseIf Cells(x, i).Value <> "" Then
FolPath = FolPath & "\" & Cells(x, i).Value
End If
End Sub
Private Sub OpenFolPath()
Dim WSH As Object
'-2:FolPathが存在するか？
If Dir(FolPath, vbDirectory) = "" Then
'フォルダが存在しない
'→エラー表記を行う
Cells(x, c + 3).Value = "ファイルが存在しません"
Else
'フォルダが存在する
'→フォルダを開く
Set WSH = CreateObject("Wscript.Shell")
WSH.Run FolPath, 2
Set WSH = Nothing
End If
End Sub
実行にあたっては下図のような表をあらかじめ作成しており、
かつフォルダは既に存在するものとする。
'フォルダは既に存在していると仮定する
'→存在しない場合は最深の階層から右へ三つのセルへエラーを表記する
Dim FolPath As String
Dim c As Long
Dim i As Long '処理を行っている階層の位置
Dim x As Long
Const goA As String = "A4" 'ディレクトリの最上層が書かれたセル位置
Const InGyo As Long = 4 '処理を始める行（二回目以降の処理は五行目から行う）
Sub 一括でフォルダを開く()
Dim R As Long
Dim myLink() As String '出力したことのあるｱﾄﾞﾚｽを格納する
ReDim Preserve myLink(0)
Dim co As Long
Dim n As Long '処理を行っているフォルダ
'二回目（5行目）以降で使用
'～子ディレクトリがない→ループから抜ける
'1回目のfalse ： 親ディレクトリの空白取得中
'true ： 空白ではない
'2回目のfalse ： 再度空白になった→ループから抜ける
Dim chF As Boolean
R = Range(goA).CurrentRegion.Rows.Count 'ディレクトリの最大数
c = Range(goA).CurrentRegion.Columns.Count '階層の深さ
'～～～4行目のディレクトリを構築する
n = InGyo '行を取得
'-1:パスを取得する
'一旦、FolPathを空白にする
FolPath = ""
x = n
For i = 1 To c '列を取得
Call GetFolPath
Next i
'-2:ファイルを開く
Call OpenFolPath
' '～～～5行目以降の処理を行う
For n = InGyo + 1 To 3 + R
'フラグを初期値にする
chF = False
'一旦、FolPathを空白にする
FolPath = ""
'浅い階層から深い階層へアドレスを読み進める
For i = 1 To c
'-0：変数ｘ = FolPathへ代入するｱﾄﾞﾚｽ（列数）
x = n '
If Cells(n, i).Value = "" Then
'空白の場合・・・
'1：chFがtrue→次の行に移動
If chF = True Then
Exit For
End If
'2:chFがfalse→上の列を読み込む(最大InGyo-1行目まで）
Do While Cells(x, i).Value = ""
If x = InGyo - 1 Then
'読み込み始めの行InGyoよりも上の行になったら処理を中止する
Exit Do
Else
x = x - 1
End If
Loop
ElseIf Cells(n, i).Value <> "" Then
'空白でない場合はその値をFolPathへ
chF = True
End If
'-1:パスを取得する
Call GetFolPath
Next i
'ファイルを開く
Call OpenFolPath
Next n
MsgBox "処理が完了しました"
End Sub
Private Sub GetFolPath()
If FolPath = "" Then
'一番上の階層
FolPath = Cells(x, i).Value
ElseIf Cells(x, i).Value <> "" Then
FolPath = FolPath & "\" & Cells(x, i).Value
End If
End Sub
Private Sub OpenFolPath()
Dim WSH As Object
'-2:FolPathが存在するか？
If Dir(FolPath, vbDirectory) = "" Then
'フォルダが存在しない
'→エラー表記を行う
Cells(x, c + 3).Value = "ファイルが存在しません"
Else
'フォルダが存在する
'→フォルダを開く
Set WSH = CreateObject("Wscript.Shell")
WSH.Run FolPath, 2
Set WSH = Nothing
End If
End Sub
Dim myIE As SHDocVw.InternetExplorer
'一つ前に戻る
myIE.GoBack
'一つ先に進む
myIE.GoForward
'更新する
myIE.Refresh
'一つ前に戻る
myIE.GoBack
'一つ先に進む
myIE.GoForward
'更新する
myIE.Refresh
＜サンプル＞
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim inF As String
Dim outF As String
inF = "*****入力元ｱﾄﾞﾚｽ*****"
outF = "*****出力先ｱﾄﾞﾚｽ*****"
FSO.CopyFolder inF, outF, True
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim inF As String
Dim outF As String
inF = "*****入力元ｱﾄﾞﾚｽ*****"
outF = "*****出力先ｱﾄﾞﾚｽ*****"
FSO.CopyFolder inF, outF, True