■PivotItems().Visible = True|False

PivotTablesをVBAで操作する時の話。
RowFieldsやColumnFieldsの特定のPivotItemsだけ表示したい場合、
全Itemを一旦表示させて、目的のItem以外をVisible = Falseにする、という処理が考えられます。
PivotItemsをLoopして、目的ItemだったらTrue、それ以外はFalse..という処理だと
全Item非表示になるタイミングがあった時にエラーになるからです。
でも、Ver.2007以降ClearAllFiltersメソッドが追加され、全Item表示が楽になったとはいえ、やはり効率は悪いです。

なので前回記事のリンク先
『マクロでピボットのPivotItemsのVisible = Trueができない』
http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+201209/12090023.txt
ここでは

Sub try()
　　Const Trg = "F1"　　　　　　　　'フィールド名
　　Const Lst = "item0001,item0002" '表示させるItemリスト
　　Dim pf As PivotField
　　Dim i　As Long
　　Dim x　As String
　　Dim s, si

　　Set pf = ActiveSheet.PivotTables(1).PivotFields(Trg)
　　pf.AutoSort xlManual, ""
　　With pf.VisibleItems
　　　　x = .Item(1).Value
　　　　For i = 2 To .Count
　　　　　　.Item(i).Visible = False
　　　　Next
　　End With
　　s = Split(Lst, ",")
　　For Each si In s
　　　　pf.PivotItems(si).Visible = True
　　Next
　　If IsError(Application.Match(x, s, 0)) Then
　　　　pf.PivotItems(x).Visible = False
　　End If

　　Set pf = Nothing
End Sub

こんなVisibleItemsのみをLoopするようなコードも提示してます。
>効率考えればHiddenItemsを一旦表示させるより
>VisibleItemsの中から１コだけ残して非表示にし、
>目的のItemを表示させるほうが良い..


ただ、リンク先にも書いているように、
全表示から処理する場合、特にItem数が多いとPivotItems().Visible = False はかなり遅くなります。
そういう場合は
>..非表示にしたい行フィールド内のセルを選択して右クリック[表示しない]..
PivotFields().DataRange に対して Deleteメソッドを使うと速く処理できます。

ちょっと計測してみました。

（実行後のイメージ）


テスト　　　　　　ScreenUpdating　　Time
try_1(Loop方式)　　　　True　　　　332.4531
try_1(Loop方式)　　　　False　　　 228.8594
try_2(Delete方式)　　　True　　　　　0.28125
try_2(Delete方式)　　　False　　　　 0.125

以下、テストコード。

Option Explicit

Sub pre() '準備--テストBook作成--
　　Const x = 8001 '97での限界値(?)
　　With Workbooks.Add(xlWBATWorksheet).Sheets(1)
　　　　.Range("A1:B2").Value = [{"F1","F2";"item0001",1}]
　　　　.Range("A2:B2").AutoFill .Range("A2:B" & x), xlFillSeries
　　　　With .PivotTableWizard(xlDatabase, "'" & .Name & "'!A1:B" & x, "")
　　　　　　.PivotFields("F1").Orientation = xlRowField
　　　　　　.PivotFields("F2").Orientation = xlDataField
　　　　End With
　　End With
End Sub
'-------------------------------------------------
Sub test() 'テスト
　　Dim n As Long:　　n = 2　　'テストプロシージャ指定
　　Dim b As Boolean: 'b = True 'ScreenUpdating指定
　　Dim t As Single

　　try_0 '条件揃えるため、一応..
　　Application.ScreenUpdating = b
　　t = Timer
　　Select Case n
　　Case 1: try_1
　　Case 2: try_2
　　End Select
　　Debug.Print "try_" & n, b, Timer - t
　　Application.ScreenUpdating = True
End Sub
'-------------------------------------------------
Private Sub try_1() 'Loop方式
　　Dim pf As PivotField
　　Dim p　As PivotItem

　　Set pf = ActiveSheet.PivotTables(1).PivotFields("F1")
　　pf.Orientation = xlHidden
　　pf.Parent.PivotCache.Refresh
　　pf.Orientation = xlRowField
　　For Each p In pf.PivotItems
　　　　Select Case p.Value
　　　　Case "item4000", "item8000" '表示アイテム名をカンマ区切りで指定
　　　　Case Else
　　　　　　p.Visible = False
　　　　End Select
　　Next
　　Set pf = Nothing
End Sub
'-------------------------------------------------
Private Sub try_2() 'Delete方式
　　Const Lst = "item4000,item8000" '表示アイテム名をカンマ区切りで指定
　　Dim pf　As PivotField
　　Dim r　 As Range
　　Dim n　 As Long
　　Dim x　 As String
　　Dim s
　　Dim si

　　Set pf = ActiveSheet.PivotTables(1).PivotFields("F1")
　　pf.Orientation = xlRowField
　　pf.Position = 1
　　Set r = pf.DataRange
　　'データ範囲の1つめのセルを仮表示アイテムとして値を記憶
　　x = r.Item(1).Value
　　n = r.Cells.Count - 1
　　If n > 0 Then
　　　　'仮表示アイテムだけ残してまとめて非表示
　　　　r.Resize(n).Offset(1).Delete
　　End If
　　'表示アイテム処理
　　s = fSplit(Lst, ",")
　　'pf.AutoSort xlManual, ""
　　On Error Resume Next
　　For Each si In s
　　　　pf.PivotItems(si).Visible = True
　　Next
　　'記憶しておいた仮表示アイテムの処理
　　If IsError(Application.Match(x, s, 0)) Then
　　　　pf.PivotItems(x).Visible = False
　　End If
　　On Error GoTo 0
　　Set pf = Nothing
End Sub
'-------------------------------------------------
Function fSplit(ByVal s As String, ByVal t As String) '97用
　　Dim n As Long
　　Dim i As Long
　　Dim p As Long

　　n = Len(s)
　　ReDim ss(n) As String
　　p = 1
　　For i = 0 To n
　　　　n = InStr(p, s, t)
　　　　If n = 0 Then
　　　　　　ss(i) = Mid$(s, p)
　　　　　　Exit For
　　　　End If
　　　　ss(i) = Mid$(s, p, n - p)
　　　　p = n + Len(t)
　　Next
　　ReDim Preserve ss(i)
　　fSplit = ss
End Function
'-------------------------------------------------
Private Sub try_0()
　　Dim pf As PivotField
　　Dim p　As PivotItem

　　Set pf = ActiveSheet.PivotTables(1).PivotFields("F1")
　　pf.Orientation = xlHidden
　　pf.Parent.PivotCache.Refresh
　　pf.Orientation = xlRowField
End Sub

■xl2003：条件付き書式の色設定だけ残す

■xl2007：条件付き書式の色設定だけ残す では[PublishObjects.Addメソッド]を使っていますが、これは2003以前では無効です。
最後に
>他に、Wordを経由させる手法でも書式が固定されて取得できるようです。これは2003以前も共通でいけるような気がしますね。
>：
>機会あったらこちらを試行してもいいかも。
..と書いてるように、Word経由を試してみました。

前記事と同じで、まずはシートを追加し、条件付き書式を設定するコード。

Option Explicit

Sub pre()
　　With Sheets.Add.Range("B5:D10")
　　　　.Formula = "=INT(RAND()*100)"
　　　　.Value = .Value
　　　　With .FormatConditions
　　　　　　.Delete
　　　　　　.Add(xlCellValue, xlLess, 40).Interior.ColorIndex = 46
　　　　　　.Add(xlCellValue, xlLess, 80).Interior.ColorIndex = 45
　　　　　　.Add(xlCellValue, xlGreaterEqual, 80).Interior.ColorIndex = 44
　　　　End With
　　　　Call try(.Cells)
　　End With
End Sub
'-------------------------------------------------
Sub try(ByRef r As Range)
　　Dim rg As Range
　　Dim x　As Long
　　Dim y　As Long
　　Dim i　As Long

　　Set rg = r.Offset(, r.Columns.Count + 1).Item(1)
　　For x = 1 To r.Columns.Count
　　　　For y = 1 To r.Rows.Count
　　　　　　With rg.Offset(i)
　　　　　　　　.Value = r(y, x).Address(0, 0)
　　　　　　　　.Offset(, 1).Value = r(y, x).Value
　　　　　　　　.Offset(, 2).Value = r(y, x).Interior.Color
　　　　　　　　.Offset(, 3).Interior.Color = .Offset(, 2).Value
　　　　　　　　i = i + 1
　　　　　　End With
　　　　Next
　　Next
　　Set rg = Nothing
End Sub

"word.application"を経由して、表示された色だけ残し条件付き書式を解除するコード。

Sub test()
　　Dim wd As Object
　　Dim r　As Range

　　Set r = ActiveSheet.Range("B5:D10")
　　r.Item(1).Select
　　Set wd = CreateObject("word.application")
　　'wd.Visible = True
　　With wd.documents.Add
　　　　r.Copy
　　　　.content.pasteexceltable False, False, False
　　　　.tables(1).Range.Copy
　　　　r.Worksheet.PasteSpecial "HTML"
　　　　.Close False
　　End With
　　wd.Quit
　　Call try(r)

　　Set r = Nothing
　　Set wd = Nothing
End Sub

（結果）

一応、取れてるようです。
#ただし色をカスタマイズしてる場合は正確には取れないみたい :(

■Worksheet_Scrollイベント（もどき:D

excelfactory.netネタです。

画面に表示されたセル範囲が変化した時のイベントを捉えたいというニーズがあったとします。
例えば
・スクロールバー操作やマウスホイール操作で画面をスクロール
・ズーム変更
・行列の高さや幅を変更
・行、列の表示/非表示
こういった操作をトリガーにして何らかのマクロを実行したい、とか。

Excel自体にはWorksheet_Scrollイベントはありませんから、
Loopを使った常時監視や、タイムラグに妥協しつつWorksheet_SelectionChangeイベントを使うか、WindowsAPIを駆使して実現するしかないような...と思ってました。
http://excelfactory.net/excelboard/excelvba/cfs.cgi?word=106710&logs=14.txt
この当時に思いついてれば良かったんですけど。

比較的簡単な手法として、Frame.ControlをWorksheetに配置して、そのLayoutイベントを利用する手がありました。
まず

Sub Macro1()
　　Sheets.Add.OLEObjects.Add ClassType:="Forms.Frame.1", Left:=0, Top:=0, Width:=1, Height:=1
End Sub

..で追加されたSheetModuleに以下のコードを置きます。

'SheetModule
Option Explicit

Private Type CHKVALUE '各値保持用
　　adrs As String　　'VisibleRangeアドレス
　　x　　As Single　　'Width
　　y　　As Single　　'Height
　　z　　As Long　　　'Zoom
End Type

Private chk As CHKVALUE
'-------------------------------------------------
Private Sub Frame1_Layout()
　　Dim msg(4) As String 'StatusBar表示用文字列
　　Dim x　　　As Single 'Width変化量
　　Dim y　　　As Single 'Height変化量
　　Dim z　　　As Long　 'Zoom変化量

　　If Not (ActiveSheet Is Me) Then Exit Sub

　　x = Me.Frame1.Left - chk.x
　　y = Me.Frame1.Top - chk.y
　　With ActiveWindow
　　　　z = .Zoom - chk.z
　　　　With .Panes(.Panes.Count).VisibleRange
　　　　　　With .Item(.Count)
　　　　　　　　'変化なければ抜ける（重複処理対策）
　　　　　　　　If (x = 0) And (y = 0) And (z = 0) Then
　　　　　　　　　　If .Left = chk.x Then
　　　　　　　　　　　　If .Top = chk.y Then Exit Sub
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　　　chk.x = .Left
　　　　　　　　chk.y = .Top
　　　　　　End With
　　　　　　chk.adrs = .Address(0, 0)
　　　　End With
　　　　chk.z = .Zoom
　　End With

　　'変化項目と変化量の記録
　　msg(0) = "Change: Scroll"
　　If x <> 0 Then msg(0) = "Chenge: Width"
　　If y <> 0 Then msg(0) = "Chenge: Height"
　　If z <> 0 Then msg(0) = "Change: Zoom"
　　msg(1) = "VisibleRange: " & chk.adrs
　　msg(2) = "Width: " & x
　　msg(3) = "Height: " & y
　　msg(4) = "Zoom: " & z
　　Application.StatusBar = Join(msg, "｜")
　　'再配置
　　Me.Frame1.Left = chk.x
　　Me.Frame1.Top = chk.y
End Sub

対象シートがActiveの時だけ実行されるように、ThisWorkbookModuleには以下のコード。

'ThisWorkbookModule
Option Explicit

Private Const WKSHT = "Sheet1"　　'対象Sheet名
'-------------------------------------------------
Private Sub Workbook_Activate()
　　With Sheets(WKSHT).Frame1
　　　　.Visible = False
　　　　.Visible = True
　　End With
End Sub
'-------------------------------------------------
Private Sub Workbook_Deactivate()
　　Sheets(WKSHT).Frame1.Visible = False
　　Application.StatusBar = False
End Sub
'-------------------------------------------------
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
　　If Sh.Name = WKSHT Then Workbook_Activate
End Sub
'-------------------------------------------------
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
　　If Sh.Name = WKSHT Then Workbook_Deactivate
End Sub

取り敢えずStatusBarに変化内容を表示するようにしています。





列のWidthと行Height、画面のZoomについては変化量を表示。
VisibleRangeについては変化した後のアドレスを表示するサンプルです。

ある程度はウマくいくようですが、完璧ではありません。
Excel.Application自体のWindowsリサイズには対応できません。
また、2007から導入されたStatusBarのズームスライダーからZoom変更するとエラーになります。（2010ではエラーは発生しないみたい）
..ので実用的とは言えないかも :P



#2010.11.16 追記）
ぃや、やっぱりダメでした。Frame.ControlのLayoutイベントの制御ってなかなか難しいですね。
VisibleRange最終セルに再配置しなければいけないのが厄介です。
ズームスライダーだけじゃなくて[Ctrl]キー+マウスホイールによるZoom変更でエラー発生するのが質悪い。
DoEventsで誤魔化せば2010では使えそうなんだけど...

...って事で本記事はボツ扱いでお願いします..orz

■xl2007：条件付き書式の色設定だけ残す

『条件付き書式によって表示された色だけ残し、条件付き書式を解除する』あるいは『条件付き書式よって表示された色を取得する』というお題です。

以前の記事でもリンク貼って紹介しましたが、例えば
http://www.keep-on.com/excelyou/2000lng4/200005/00050350.txt
のように、2003までは条件付き書式の条件式を評価する方法で取得が可能でした。
2007からは仕様変更とバグの為、この類の手法はかなり面倒な事になります。
詳細は■xl2007：ModifyAppliesToRangeメソッドなどの一連の過去記事に書いてます。
[適用先]のセル範囲が条件ごとに違う場合に[Formula1プロパティ]などが正しく取得できない、といった事が主な理由です。

条件付き書式の結果である色設定などを単純に取得したいだけなら、[Webページとして発行]機能が使えます。
2007ではWebページで保存したmhtファイルをExcelで開くと、セル背景色などの書式情報が保持されています。
2003以前では取れませんでした。

まずはシートを追加し、条件付き書式を設定するコード。

Option Explicit

Sub pre()
　　With Sheets.Add.Range("B5:D10")
　　　　.Formula = "=INT(RAND()*100)"
　　　　.Value = .Value
　　　　.FormatConditions.AddColorScale ColorScaleType:=2

　　　　Call try(.Cells)

　　End With
End Sub

Sub try(ByRef r As Range)
　　Dim rg As Range
　　Dim x　As Long
　　Dim y　As Long
　　Dim i　As Long

　　Set rg = r.Offset(, r.Columns.Count + 1).Item(1)
　　For x = 1 To r.Columns.Count
　　　　For y = 1 To r.Rows.Count
　　　　　　With rg.Offset(i)
　　　　　　　　.Value = r(y, x).Address(0, 0)
　　　　　　　　.Offset(, 1).Value = r(y, x).Value
　　　　　　　　.Offset(, 2).Value = r(y, x).Interior.Color
　　　　　　　　.Offset(, 3).Interior.Color = .Offset(, 2).Value
　　　　　　　　i = i + 1
　　　　　　End With
　　　　Next
　　Next
　　Set rg = Nothing
End Sub

（結果）

[PublishObjects.Addメソッド]を使って、表示された色だけ残し条件付き書式を解除するコード。

Sub test()
　　Dim ws　As Worksheet
　　Dim tmp As String

　　'既存ファイルに注意
　　tmp = Application.DefaultFilePath & "¥temp.mht"
　　With ThisWorkbook
　　　　Set ws = .ActiveSheet
　　　　.PublishObjects.Add( _
　　　　　　xlSourceSheet, tmp, ws.Name, "", xlHtmlStatic _
　　　　　　).Publish True
　　End With
　　ws.UsedRange.FormatConditions.Delete
　　With Workbooks.Open(tmp)
　　　　.Sheets(1).UsedRange.Copy
　　　　ws.Cells(1).PasteSpecial xlPasteFormats
　　　　Application.CutCopyMode = False
　　　　.Close False
　　End With
　　Kill tmp

　　Call try(ws.Range("B5:D10"))

　　Set ws = Nothing
End Sub

（結果）

※ただし、書式に「データバー」や「アイコンセット」、グラデーション色などを使用している場合はmhtファイルでも保持されませんので取得できません。

他に、Wordを経由させる手法でも書式が固定されて取得できるようです。これは2003以前も共通でいけるような気がしますね。
http://moug.net/faq/viewtopic.php?t=53734
（ログ保管期間が限られてます。リンク切れたらごめんなさい。）
機会あったらこちらを試行してもいいかも。

■組み込み定数の数値から文字列定数を取得

月刊「半角チルダ」１月号です。（うそ XD

Q&A掲示板に出入りしてると、自分ではあまりニーズを感じない要件に触れる事ができて、それが意外と勉強になる事が多いんですよね。
Office 2003 excel vbaでグラフの種類を一系列毎に判定 - 教えて！goo
ここで TypeLibInformation ActiveX オブジェクト (tlbinf32.dll) について知る事ができました。
せっかくなので、ちょっとお試し。

Option Explicit

Sub pre()
　　'サンプルデータシート追加し、３系列チャートを作成
　　Dim ws As Worksheet
　　Dim r　As Range
　　Dim s　As String
　　Dim i　As Long
　　Dim v

　　v = VBA.Array(, xlColumnClustered, xlLine, xlLineMarkers)
　　With Sheets.Add
　　　　Set r = .Range("A1:C10")
　　　　r.Formula = "=int(rand()*100)"
　　　　With .ChartObjects.Add(.Range("D1").Left, 0, 250, 200).Chart
　　　　　　.HasLegend = False
　　　　　　.ChartType = xlColumnClustered
　　　　　　For i = 1 To 3
　　　　　　　　With .SeriesCollection.NewSeries
　　　　　　　　　　.Values = r.Columns(i)
　　　　　　　　　　.ChartType = v(i)
　　　　　　　　End With
　　　　　　Next
　　　　End With
　　End With
　　Set r = Nothing
End Sub

まずはサンプルチャートを作成。



ActiveSheet.ChartObjects(1).Chart の各系列の ChartType を文字列定数で取得するサンプルです。

Sub test()
　　Dim TLI As Object
　　Dim cnt As Long
　　Dim i　 As Long
　　Dim v() As String

　　If fGetTLIap(TLI) Then
　　　　With ActiveSheet.ChartObjects(1).Chart.SeriesCollection
　　　　　　cnt = .Count
　　　　　　ReDim v(1 To cnt)
　　　　　　For i = 1 To cnt
　　　　　　　　v(i) = i & " : " & fConstStr(TLI, "xlcharttype", .Item(i).ChartType)
　　　　　　　　'Debug.Print v(i)
　　　　　　Next
　　　　End With
　　　　MsgBox Join(v, vbLf)
　　End If

　　Set TLI = Nothing
End Sub
'---------------------------------------------------------------------
Function fGetTLIap(ByRef TLI As Object) As Boolean
　　Dim aPath As String
　　Dim x　　 As Long

　　On Error Resume Next
　　With Application
　　　　x = Val(.Version)
　　　　If x > 9 Then
　　　　　　aPath = .Path & "¥EXCEL.EXE"
　　　　Else
　　　　　　aPath = .Path & "¥EXCEL" & CStr(x) & ".OLB"
　　　　End If
　　End With
　　Set TLI = CreateObject("TLI.TLIApplication").TypeLibInfoFromFile(aPath)
　　fGetTLIap = Not (TLI Is Nothing)
End Function
'---------------------------------------------------------------------
Function fConstStr(ByRef TLI As Object, _
　　　　　　　　　 ByVal cName As String, _
　　　　　　　　　 ByVal cValue As Long) As String

　　Dim MI　As Object 'MemberInfo
　　Dim ret As String

　　On Error GoTo extLine
　　For Each MI In TLI.Constants.NamedItem(cName).Members
　　　　If MI.Value = cValue Then
　　　　　　ret = MI.Name
　　　　　　Set MI = Nothing
　　　　　　Exit For
　　　　End If
　　Next

extLine:
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　ret = .Number & vbLf & .Description
　　　　End If
　　End With
　　fConstStr = ret
End Function

結果。
1 : xlColumnClustered
2 : xlLine
3 : xlLineMarkers