隠しシートの表示

通常はメニューの「書式」-「シート」-「再表示」で非表示シートを表示可能。

しかし、マクロで「VeryHidden」をセットされると「再表示」でも見ることができない。
例)Sheets(“aaa”).Visible = xlVeryHidden

VeryHiddenのシートが存在するかを確認する方法:
1)VBAエディター上のイミディエイトボックスを表示
2)存在するシート数を確認する
 ?sheets.Count
 4
3)表示されているシート数が4未満の場合は、VeryHiddenがあり得る
4)下記のコマンドで強制表示させる(イミディエイトボックス内)
 for i=1 to 4:Sheets(i).Visible=true:next

ピボット並び替え&上位フィルター

Sub run()
	'引数:並べ替えのフィールド名、対象のシート名、Pivot実データの開始Y番号,TOP幾つまでを表示するか
	pivot_SORT_TOP “TITLE", “Sheet4", 5, 10
End Sub

'X軸は日付など、並び替え可能な項目であること
Sub pivot_SORT_TOP(CMname As String, pivot_sheet As String, Y As Long, TOP As Integer)

	Dim X As Long, CH As String

	Sheets(pivot_sheet).Select

	On Error Resume Next
	'縦の項目を一度、全部表示にする
	For i = 1 To ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems.Count
		ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems(i).Visible = True
	Next
	
	'Pivotの末列の座標を探す
	X = 2
	Do While Cells(Y – 1, X) <> “": X = X + 1: Loop
	X = X – 1
	
	'横列の昇順並び替え
	Cells(Y – 1, 2).Select
	Selection.Sort Order1:=xlAscending, Type:=xlSortLabels, OrderCustom:=1, _
		Orientation:=xlLeftToRight, SortMethod:=xlPinYin
	
	'並び替えたい列を選択
	Cells(Y, X).Select
	'Range(Chr(64 + X) & Y).Select
	
	'X,Y座標をR1C1形式に変換
	CH = “R" & Y & “C" & X
	'末列を降順でSORT
	Selection.Sort Key1:=CH, Order1:=xlDescending, Type:=xlSortValues, _
		OrderCustom:=1, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
	
	'表示項目がTOP指定より多い場合は、フィルター処理
	If ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems.Count > TOP Then
	
		On Error Resume Next
		'TOP以降は非表示する
		For i = TOP + 1 To ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems.Count
			ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems(i).Visible = False
		Next
	End If
	On Error GoTo 0
	
End Sub

グラフのバーをグループ単位で色分け

'グラフのバーをグループ単位で色分け
'大前提:実行前に対象のグラフが選択されていること
Sub Set_Color_Bar()
	
	Dim i As Integer, N As Integer

	'バーの数分だけループ(この例では13個)
	For i = 1 To ActiveChart.SeriesCollection.Count
		N = Val(Right(ActiveChart.SeriesCollection(i).Name, 2))
		'何番目のバーを処理しているか
		If i < 5 Then
			'最初の4本までは青系のバーにする
			Bar_attr i, 33
		ElseIf i < 9 Then
			'最初の5~8本は黄系のバーにする
			Bar_attr i, 6
		Else
			'最初の9本目以降は紫系のバーにする
			Bar_attr i, 7
		End If
	Next
	
	'おまけ
	'ActiveChart.SeriesCollection(i).Name
	'これには「WK01」などの凡例の名称が入る
	
End Sub

'指定バーの色を変更
Sub Bar_attr(bar As Integer, c As Integer)
			'何番目のバーか、色番号
	On Error GoTo pass
	'対象のバーを選択
	ActiveChart.SeriesCollection(bar).Select
	'グラデーションセット
	Selection.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=4, Degree:=0.231372549019608
	Selection.Fill.Visible = True
	'色をセット
	Selection.Fill.ForeColor.SchemeColor = c
pass:
	On Error GoTo 0

End Sub

Outlookを呼び出してMail作成

'Outlookを呼び出してMail作成
Sub OUTLOOK()
	Dim objOutlook As OUTLOOK.Application
	Dim objOutlookMsg As OUTLOOK.MailItem
	Dim objOutlookRecip As OUTLOOK.Recipient
	Dim objOutlookAttach As OUTLOOK.Attachment
	
	Set objOutlook = CreateObject(“Outlook.Application")
	Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
	'メイン
	With objOutlookMsg
		.Subject = “title"
		.Body = “本文"
		'宛先準備
		Set objOutlookRecip = .Recipients.Add(“xxx@bbb.com")
		objOutlookRecip.Type = olTo
		Set objOutlookRecip = .Recipients.Add(“zzz@bbb.com")
		objOutlookRecip.Type = olCC
		'完成Mailを表示
		.Display
		'いきなり送付させる場合は下記を使用
		'.SEND
	End With
	
	Set objOutlookMsg = Nothing
	Set objOutlook = Nothing
	
	MsgBox “送付完了!"

End Sub

フォームフィルター&ソート&リフレッシュ&行保管

Private Sub Form_Load()
	
	'表示にフィルターをかける
	Me.Filter = “xxx=" & ZZZ
	Me.FilterOn = True
		
	'SORT指定
	Me.OrderBy = “ORDER_NUMBER ASC"
	Me.OrderByOn = True
	
End Sub

'編集中の行を保管する
Sub SAVE_CURRENT_RECORD()
	DoCmd.RunCommand acCmdSaveRecord
End Sub

'画面をリフレッシュ
Private Sub BTN_refresh_Click()
	Me.Requery
End Sub

IEを呼び出し&URL指定で開く

'FIELDをWクリックしたら、IE呼び出し
Private Sub FIELD_DblClick(Cancel As Integer)
	'
	Dim IE As Object
	'IE準備
	Set IE = CreateObject(“internetExplorer.application")
	'IE起動&URL開く
	IE.Navigate “http://~~~~?xxx=" & ZZZ.Value
	'IE表示
	IE.Visible = True
	'表示終わるまで待機
	Do While IE.Busy = True: DoEvents: Loop
	'リソース開放
	Set IE = Nothing
	'
End Sub

APIを使ってログイン名を取得

'Windowsログイン名取得API
Private Declare Function GetUserName Lib “ADVAPI32.dll" _
	Alias “GetUserNameA" _
	(ByVal lpBuffer As String, nSize As Long) As Long

Sub test()
	Dim strBuffer As String
	Dim lngLngs As Long
	Dim lngRet As Long
	Dim Get_User As String
	'
	' Bufferを確保
	strBuffer = String(256, Chr(0))
	lngLngs = Len(strBuffer)
	'
	' ログインユーザー名取得
	lngRet = GetUserName(strBuffer, lngLngs)
	Get_User = UCase(Left$(strBuffer, InStr(1, strBuffer, Chr(0)) – 1))
	'
	MsgBox Get_User
	'
End Sub

全シート内PIVOTをリフレッシュ

'全シート内のPIVOTを無条件リフレッシュ
Sub ALL_PIVOT_UPDATE()

	If MsgBox(“全Pivotを一括更新します。" & vbCrLf & _
		“1Pivot xx秒ほどかかります。", vbYesNo) <> vbYes Then Exit Sub
	
	'PIVOTが無いシートはエラーになるため、無視するように設定
	On Error Resume Next
	'全シートを順番に更新
	For i = 1 To ActiveWorkbook.Sheets.Count
		Sheets(i).Activate
		'PIVOTのリフレッシュ
		ActiveWorkbook.Sheets(i).PivotTables(1).PivotCache.Refresh
	Next
	'エラー処理を有効にする
	On Error GoTo 0
	
	MsgBox “done!"

End Sub

ACCESS内容を動的PIVOTにする

MS-ACCESS内のクエリーをPIVOT化する(リンクされているためリフレッシュ可能)
更にそのPIVOTからグラフを作成する
sample table field: shohin,month,bunsi,bunbo

Sub make_pivot(Tbl$, PVN As Integer, GOAL As Boolean)
	'Tbl$ = 対象のTable/クエリー名
	Dim PV As Variant, i As Integer
	'ソース情報(MDB)の取り出し文を作成
	a1$ = “ODBC;DSN=MS Access Database;"
	a2$ = “DBQ=\\file_server\path\FIR09.mdb;"
	a3$ = “DefaultDir=\\file_server\path;"
	a4$ = “DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;"
	'pivot名称(内部用)
	PV = “pivot" & PVN
	'PIVOT用に新規シート作成
	Worksheets.Add
	'PVOTシート名はTable名とする
	ActiveSheet.Name = Tbl$
	Range(“B4").Select
	'PIVOT作成
	With ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)
		.Connection = Array(Array(a1$), Array(a2$), Array(a3$), Array(a4$))
		.CommandType = xlCmdSql
		.CommandText = Array(“SELECT * FROM “ & Tbl$)
		.CreatePivotTable TableDestination:=“R3C1", TableName:=PV, DefaultVersion:=xlPivotTableVersion10
	End With
	
	On Error Resume Next
	'RATEフィールドの追加(DBには無いField)
	ActiveSheet.PivotTables(PV).CalculatedFields.Add “RATE", “=bunshi/bunbo", True
	ActiveSheet.PivotTables(PV).PivotFields(“RATE").Orientation = xlDataField
	Range(“B4").Select
	
	'グラフ作成
	Charts.Add
	ActiveChart.SetSourceData Source:=Sheets(Tbl$).Range(“B4")
	ActiveChart.Location Where:=xlLocationAsNewSheet
	ActiveChart.ChartArea.Select
	ActiveChart.ChartType = xlColumnClustered
	ActiveChart.Location Where:=xlLocationAsNewSheet
	ActiveWindow.Zoom = 100
	ActiveChart.Axes(xlValue).Select
	Selection.TickLabels.NumberFormatLocal = “0.00%"
	ActiveChart.ChartArea.Select
	Selection.AutoScaleFont = True
	With Selection.Font
		.Name = “Verdana"
		.Size = 8
		.Strikethrough = False
		.Superscript = False
		.Subscript = False
		.OutlineFont = False
		.Shadow = False
		.Underline = xlUnderlineStyleNone
		.ColorIndex = xlAutomatic
		.Background = xlAutomatic
	End With
	
	'グラフに縦横フィールド名セット
	ActiveChart.PivotLayout.PivotTable.PivotFields(“shohin").Orientation = xlRowField
	ActiveChart.PivotLayout.PivotTable.PivotFields(“shohin").Position = 1
	ActiveChart.PivotLayout.PivotTable.PivotFields(“month").Orientation = xlColumnField
	ActiveChart.PivotLayout.PivotTable.PivotFields(“month").Position = 1
	'bunboの合計をを値としてセット
	ActiveChart.PivotLayout.PivotTable.AddDataField ActiveChart.PivotLayout. _
		PivotTable.PivotFields(“bunbo"), “合計 / bunbo", xlSum
	   
	On Error GoTo 0
	'グラフシートの名前をセット
	ActiveSheet.Name = Tbl$ & “グラフ"
	
	'凡例の表示
	ActiveChart.ChartArea.Select
	ActiveChart.HasLegend = True
	'凡例の場所設定
	ActiveChart.Legend.Select
	Selection.Position = xlBottom
	ActiveChart.Deselect
	
End Sub