goo blog サービス終了のお知らせ 

半角チルダ

ExcelVBA、その他。
覚え書きや、補足資料などのスクラップブック。
end-u(1037781)

■PivotItems().Visible = True|False

2012-10-01 22:00:00 | VBA Tips
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の中から1コだけ残して非表示にし、
>目的の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
Comment
  • X
  • Facebookでシェアする
  • はてなブックマークに追加する
  • LINEでシェアする

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

2010-12-25 22:00:00 | VBA Tips
■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

(結果)


一応、取れてるようです。
#ただし色をカスタマイズしてる場合は正確には取れないみたい :(
Comment
  • X
  • Facebookでシェアする
  • はてなブックマークに追加する
  • LINEでシェアする

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

2010-09-14 23:00:00 | VBA Tips
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
Comment
  • X
  • Facebookでシェアする
  • はてなブックマークに追加する
  • LINEでシェアする

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

2010-09-10 22:00:00 | VBA Tips
『条件付き書式によって表示された色だけ残し、条件付き書式を解除する』あるいは『条件付き書式よって表示された色を取得する』というお題です。

以前の記事でもリンク貼って紹介しましたが、例えば
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
(ログ保管期間が限られてます。リンク切れたらごめんなさい。)
機会あったらこちらを試行してもいいかも。
Comment
  • X
  • Facebookでシェアする
  • はてなブックマークに追加する
  • LINEでシェアする

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

2010-01-30 01:00:00 | VBA Tips
月刊「半角チルダ」1月号です。(うそ XD

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

Option Explicit

Sub pre()
  'サンプルデータシート追加し、3系列チャートを作成
  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
Comment
  • X
  • Facebookでシェアする
  • はてなブックマークに追加する
  • LINEでシェアする