複数選択 カレントパス、ファイル・フォルダ検索 ExecuteExcel4Macro

VBA系
2016/7/30
複数選択
Sheets(1).Select
Sheets(2).Select (False)
Sheets(3).Select (False)
カレントパス、ファイル・フォルダ検索
ChDir ThisWorkbook.Path
Dim buf$, msg$
buf = Dir("*", vbDirectory)
Do While buf <> ""
If GetAttr(buf) And vbDirectory Then
If buf <> "." And buf <> ".." Then msg = msg + buf + vbCrLf
End If
buf = Dir()
Loop
MsgBox msg
ExecuteExcel4Macro
Cells(i, 1) = ExecuteExcel4Macro("'C:\[Book1.xls]Sheet1'!R" & i & "C1")
閉じているブックの参照
='D:\aaa\[DB.xlsm]Sh'!B2
オートフィルタ―解除
ActiveSheet.AutoFilterMode = False
Chdir、とにかくデスクトップへ、CreateObject
Dim Fpath As String
Fpath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
-1-
VBA系
2016/7/30
コマンドバー
Sub a()
With CommandBars("Cell").Controls.Add(before:=3)
.Caption = "Label"
.OnAction = "M_name"
.State = True
.Tag = "Temp"
.FaceId = 481
.BeginGroup = True
End With
End Sub
For Each c In CommandBars("Cell").Controls
'CommandBars("Cell").Reset
VBA実行ショートカット作成
Sub a()
Application.MacroOptions Macro:="Mname", ShortcutKey:="j"
End Sub
Sub Sampl6()
Application.OnKey "{F3}", "Sample1"
End Sub
OnKeyメソッドで設定したショートカットキー解除
Sub Sampl6()
Application.OnKey "{F3}"
End Sub
Application.OnKey "^j"
数式
Alt
%
Shift
+
Ctrl
^
MsgBox Cells(1, 1).FormulaLocal
図形タイプ検索
Sub Sample()
Dim c As Object
For Each c In ActiveSheet.Shapes
MsgBox TypeName(c.DrawingObject)
Next c
.type=1
End Sub
.typename(～ =OLEobject
-2-
メール送信
VBA系
2016/7/30
Sub a()
With CreateObject("outlook.application")
With .createitem(olmailitem)
.Recipients.Add("[email protected]").Type = 1
.Recipients.Add("[email protected]").Type = 2 '' CC"
.Recipients.Add("[email protected]").Type = 3 ''BCC"
.Subject = "件名"
.bodyformat = 1
.body = "本文"
.attachments.Add "D:\aaa\k13.jpg"
.send
End With
End With
End Sub
レジストリ
Sub Regedit_insert()
SaveSetting "ApplicationName", "SectionName", _
"KeyName3", "DataName3"
End Sub
Sub Regedit_call()
Dim buf As String
buf = GetSetting("ApplicationName", "SectionName", _
KeyName, "存在しません")
MsgBox buf
End Sub
Sub AllSection_Call() '' 二次元配列でレジストリ取得
Dim tmp As Variant, i As Byte
tmp = GetAllSettings("applicationname", "sectionname")
For i = 0 To 1
MsgBox tmp(i, 0) & vbCrLf & tmp(i, 1)
Next i
End Sub
Sub Regedit_Delete()
DeleteSetting "Applicationname", "Sectionname", "Keyname"
End Sub
-3-
フォームでのレジストリ使用
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
VBA系
2016/7/30
SaveSetting "Mymacro", "Form", "Top", Top
SaveSetting "Mymacro", "Form", "Left", Left
SaveSetting "Mymacro", "Form", "Text", TextBox1.Text
If OptionButton1 = True Then _
SaveSetting "Mymacro", "Form", "Option", OptionButton1.Caption
If OptionButton1 = False Then _
SaveSetting "Mymacro", "Form", "Option", OptionButton2.Caption
End Sub
Private Sub UserForm_Initialize()
startupposition = 0
Dim pos As Long, buf As String
pos = Val(GetSetting("Mymacro", "Form", "Top", "100"))
Me.Top = pos
pos = Val(GetSetting("Mymacro", "Form", "Left", "100"))
Me.Left = pos
buf = GetSetting("Mymacro", "Form", "Text")
TextBox1.Text = buf
buf = GetSetting("Mymacro", "Form", "Option", "")
If buf = OptionButton1.Caption Then OptionButton1 = True
buf = GetSetting("Mymacro", "Form", "Option", OptionButton2.Caption)
If buf = OptionButton2.Caption Then OptionButton2 = True
End Sub
グラフ挿入
With ActiveSheet.ChartObjects.Add(30, 50, 300, 200).Chart
.ChartType = xlColumnClustered
.SetSourceData Source:=Range("A1:B3")
End With
列系3のグラフ色変更
With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Points(3)
.Interior.ColorIndex = 5
End With
-4-
列系の中から、1,000 以上の値のグラフ色変更
VBA系
2016/7/30
Dim tmp As Variant, I As Long
tmp = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Values
For I = 1 To UBound(tmp)
If tmp(I) >= 1000 Then
With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Points(I)
.Interior.ColorIndex = 6
End With
End If
Next I
Shell 関数
Call Shell("EXCEL D:\予算.xlsm", 1)
Call Shell("winword D\京.docx", 1)
ウィンドウサイズ
ActiveWindow.Width = 300
ActiveWindow.Height = 300
1セル文字列、複数文字列へ分割
CLEAN(MID(SUBSTITUTE(A$1,CHAR(32),REP
T(CHAR(9),99)),ROW(C1)*99-98,99))
aa
aa bb cc ⇒ bb
cc
図形選択、セル番地
If c.TopLeftCell.Address = "$B$12" Then c.Select
OLE Objects
Dim Obj As OLEObject
For Each Obj In ActiveSheet.OLEObjects
If Obj.Name Like "TextBox*" Then
Obj.Object.Value = ""
ElseIf Obj.Name Like "CheckBox*" Then
Obj.Object.Value = False
End If
Next
-5-
VBA系
2016/7/30
コメント
Sub a()
Application.DisplayCommentIndicator = 1
With Cells(1, 1)
.AddComment.Shape.Fill.UserPicture "c:\\ayu.jpg"
.Comment.Shape.Select
With Selection
.Text = "京都"
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Fill.Transparency = 0.6
.ShapeRange.Width = 200
End With
End With
Application.DisplayCommentIndicator = -1
End Sub
ウィンドウ、最大・最少
Application.WindowState = xlMinimized
Application.WindowState = xlMaximized
テキストファイル取込
ActiveSheet.QueryTables.Add("Text;" & N, _
Range("A1")).Refresh BackgroundQuery:=0
【優位性】①utf8などキャラ指定可, ②列削除可, ③列を文字列指定でゼロ落ち可
④シングルQ or ダブルQ or 無し 指定可, ⑤開始行指定可能
⑥区切り文字列指定可能(カンマ以外にタブも可)
.TextFileColumnDataTypes = Array(1, 2, 5, 9) ⇒ (標準, 文字列, 日付, 削除)
ユーザーネーム
Cells(1, 1) = Application.UserName
ユーザー名
MsgBox CreateObject("WScript.Network").UserName
連続範囲最終列
MsgBox Range("B2").CurrentRegion.Columns.Count
あくまで選択範囲のカラム数
リピート
MsgBox String(10, "*")
-6-
VBA系
2016/7/30
ピボット範囲変更
ActiveWorkbook.Names.Add Name:="pv範囲", RefersToR1C1:= _
=OFFSET(元データ!R2C2,,,COUNTA(元データ!C1),3)
pv.SourceData = Range("hoge").Address(True, True, xlR1C1, True)
フォーム上、フォームコントロール追加
Dim s As Integer
Dim myCheckBox As Control
For s = 1 To Sheets.Count
Set myCheckBox = Me.Controls.Add("Forms.CheckBox.1")
With myCheckBox
.Height = 20
.Width = 132
.Left = 10
.Top = (s - 1) * .Height + 10
.Caption = Sheets(s).Name
End With
Next s
画像複製
Set px = ActiveSheet.Pictures(1).Duplicate
同シート内に限る
フォーム、OLEコントロール
ActiveSheet.DrawingObjects("ListBox1").ListFillRange = "Sheet1!A1:A10"
アクティベイト
AppActivate "Sample.txt - メモ帳", True
AppActivate "Microsoft Excel", True
B = ActiveWindow.Caption
DoEvents
AppActivate B, True
R1C1 ⇔ A1
R[-3]C[-7]:R[1]C[-5]
Range("A1") = Application.ConvertFormula("A1:C5", xlA1, xlR1C1)
Range("A2") = Application.ConvertFormula("R2C3", xlR1C1, xlA1)
$C$2
-7-
VBA系
2016/7/30
ファイルシステム
With ActiveWorkbook
' タイトル
Cells(1, 2).Value = .BuiltinDocumentProperties("Title").Value
' サブタイトル
Cells(2, 2).Value = .BuiltinDocumentProperties("Subject").Value
' 作成者
Cells(3, 2).Value = .BuiltinDocumentProperties("Author").Value
' 管理者
Cells(4, 2).Value = .BuiltinDocumentProperties("Manager").Value
' 会社名
Cells(5, 2).Value = .BuiltinDocumentProperties("Company").Value
' 分類
Cells(6, 2).Value = .BuiltinDocumentProperties("Category").Value
' キーワード
Cells(7, 2).Value = .BuiltinDocumentProperties("Keywords").Value
' コメント
Cells(8, 2).Value = .BuiltinDocumentProperties("Comments").Value
' ハイパーリンクの起点
Cells(9, 2).Value = .BuiltinDocumentProperties("Hyperlink base").Value
' 作成日時
Cells(10, 2).Value = .BuiltinDocumentProperties("Creation date").Value
' 更新日時
Cells(11, 2).Value = .BuiltinDocumentProperties("Last save time").Value
' 更新者
Cells(12, 2).Value = .BuiltinDocumentProperties("Last author").Value
End With
タイマー
Dim s_time, e_time
MsgBox "OKをおしてください"
s_time = Timer
e_time = Timer
MsgBox "マクロスタートからOKを押すまでの時間は " &　e_time - s_time & " 秒でした"
Autfilter 日付複数選択
xlSh.Range("B3").AutoFilter 2, Operator:=xlFilterValues _
, Criteria1:=Array(#1/2/2015#, #1/13/2015#, "2015/1/5")
●Operator:=xlFilterValuesは必須
日付は#Jan/1# など入力するとVBEで自動変換される
◆条件を満たすレコード数 = フィルタ抽出後のセル数をSpecialcells-Visible からカウント
-8-
VBA系
2016/7/30
Evaluate メソッド
MsgBox Evaluate("SUM(A1:A3)")
MsgBox [SUM(A1:A3)]
MsgBox WorksheetFunction.Sum(Range("A1:A3"))
MsgBox [a1+a2]
ボタンコントロール追加
With ActiveSheet.Buttons.Add(80, 50, 0, 0)
.OnAction = "VBA_Name"
.Characters.Text = "テキスト"
.Characters.Font.Size = 14
.Characters.Font.Color = RGB(255, 255, 255)
.AutoSize = True
End With
2007で複数シートピボット
ActiveWorkbook.PivotCaches.Create(xlConsolidation, _
Array("Sheet1!R1C1:R6C3", "Sheet2!R1C1:R6C3"), 3) _
.CreatePivotTable "R1C1"
圧縮
ZipF = Path & "CSV1.zip"
With CreateObject("Scripting.FileSystemObject").CreateTextFile(ZipF)
.Write "PK" & Chr(5) & Chr(6) & String(18, 0)
.Close
End With
CreateObject("Shell.Application").Namespace(ZipF).CopyHere Path & "CSV1.csv"
CreateObject("Shell.Application").Namespace(ZipF).CopyHere Path & "CSV2.csv"
解凍
With CreateObject("Shell.Application")
.Namespace(PathTo & "\").CopyHere .Namespace(【.zip】フルネーム).Items
End With
zipフォルダ内が複数ファイルでも可能
Shell で開く
Dim WSH
Set WSH = CreateObject("Wscript.Shell")
WSH.Run "C:\My Documents\Sample.txt", 3
Set WSH = Nothing
-9-
VBA系
2016/7/30
フォルダを開く
Shell "C:\Windows\Explorer.exe " & Path, 1
ピボットの集計行を削除
For Each PvtFld In .PivotFields
PvtFld.Subtotals(1) = False
Next PvtFld
コピーファイル、フォルダ
FSO.CopyFile "C:\test\*.bmp", "C:\test\hoge\", False
ファイル名にワイルドカート可能
第三引数にFalse指定で上書き無し、エラー扱い
ファイル・フォルダの存在確認
Debug.Print FSO.FileExists("C:\test\test.txt")
理論値で
拡張子付ファイル名・拡張子無しファイル名
Debug.Print FSO.GetParentFolderName("C:\Sample1.xlsm")
Debug.Print FSO.GetBaseName("C:\test\001.bmp")
Debug.Print FSO.GetExtensionName("C:\test\001.bmp")
上段は'C:\'
フォルダパス
中段は'001'
ファイル名（拡張子無し）
下段は'bmp'
ファイル拡張子
ファイルタイプ
MsgBox FSO.GetFile("C:\Sample1.xlsm").Type
Microsoft Office Excel マクロ有効ワークシート
画像の保存
SavePicture UserForm1.Image1.Picture, "C:\Users\test.bmp"
Reset ステートメント
Openで開いているももの全てを閉じる。単純【Reset】の1行のみ
- 10 -
VBA系
2016/7/30
エクスプローラー操作
Dim WND As Object
Dim W As Object
Set WND = CreateObject("Shell.Application")
For Each W In WND.Windows
MsgBox TypeName(W) & Chr(13) & _
W.FullName & Chr(13) & W.LocationURL
If Right$(W.FullName, 12) = "iexplorer.exe" Then MsgBox "ie"
W.Navigate "File:///c:\"
W.Navigate "yahoo.co.jp"
W.Quit
Next W
フィルタ関数
v = Filter(Ar, "A", True, 0)
Filter(sourcearray,match[,include[,compare]])
一次配列【Ar】から、第二引数【A】を『含む』
『含む』の判断は第三引数IncludeのTrue、省略可能
└ True = 含む, False = 含まない ⇒ Like演算子ではない
└ ワイルドカート不可
第四引数Compare は、テキスト比較=0、バイナリ比較=1
省略可能
複数回数センドキー
SendKeys "{UP 5}"
上キーを5回
他ブックマクロ実行
Set xlBK = GetObject(CurrentProject.Path & "\MyFunc2.xlsm")
xlBK.Application.Run "xlFunc", "kyouto"
AccessからExcelモジュール実行可能, 第一引数=Module名, 第二以降は引数
モジュール名(引数) As String などのように返し型モジュールでも実行可
プライベート系は不可
書式検索
Application.FindFormat.Interior.Color = vbRed
Set R = Cells.Find("", ActiveSheet.UsedRange.SpecialCells(11), _
SearchDirection:=xlPrevious, SearchFormat:=True)
SearchDirection xlNext : xlPrevious
- 11 -
VBA系
2016/7/30
表示機能
ActiveWindow.DisplayGridlines = False
枠線
ActiveWindow.DisplayHeadings = False
見出し
Application.DisplayFormulaBar = False
数式バー
Application.DisplayFullScreen = True
全画面
別窓IE処理
Dim WithEvents IE As InternetExplorer
Dim IE2 As InternetExplorer
'/******* フォームシートイベント *************/
Private Sub IE_NewWindow2(ppDisp As Object, Cancel As Boolean)
Set IE2 = CreateObject("InternetExplorer.Application")
Set ppDisp = IE2
End Sub
'/******* フォームシートイベント *************/
実行アプリ一覧、AppActivate用
Sub Sample1()
Dim WD, task, n As Long
Set WD = CreateObject("Word.Application")
For Each task In WD.Tasks
If task.Visible = True Then
''Wordを起動します
''Word VBAのTasksコレクションを調べます
''タスク(プロセス)が実行中だったら
n=n+1
Cells(n, 1) = task.Name
''タスクの名前を書き出します
End If
Next
WD.Quit
Set WD = Nothing
End Sub
印刷タイトル
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$2"
.PrintTitleColumns = "$A:$A"
End With
- 12 -
VBA系
2016/7/30
印刷範囲設定・解除、プリントプレビュー
ActiveSheet.PageSetup.PrintArea = _
Range("B2").CurrentRegion.Address
ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PrintPreview
印刷ヘッダー、フッター設定
ActiveSheet.PageSetup.CenterHeader = ActiveSheet.Name
ActiveSheet.PageSetup.LeftFooter = Range("A1").Value
印刷中央寄せ
ActiveSheet.PageSetup.CenterHorizontally = True
ActiveSheet.PageSetup.CenterVertically = True
改ページ位置取得
ActiveSheet.HPageBreaks(1).Location.Select
２ページ目の先頭行左位置
ActiveSheet.HPageBreaks(2).Location.Select
３ページ目の先頭行左位置
HPageBreaks ⇔ VPageBreaks (VPageBreaks.Countなど)
ページ位置、フッターへ
（ 現在ページ / 総ページ )
ActiveSheet.PageSetup.CenterFooter = _
"&F (" & n & "/" & myWSCnt & "ページ)"
テーブルスタイル・集計行
ActiveSheet.ListObjects(1).TableStyle = "TableStyleLight15"
ActiveSheet.ListObjects(1).TableStyle = "TableStyleLight16"
ActiveSheet.ListObjects(1).ShowTotals = True
xlSh.ListObjects("tbl").TableStyle = "TableStyleLight15"
xlSh.PivotTables("pv").TableStyle2 = "PivotStyleLight22"
挿入写真の縦横比
c.ScaleHeight 1, msoTrue
c.ScaleWidth 1, msoTrue
- 13 -
シェイプ図形操作、角度・影まとめ
VBA系
2016/7/30
Set Sh = ActiveSheet.Shapes.AddShape(21, 50, 50, 120, 100)
Sh.IncrementRotation 30 '回転角度
'Rotation=絶対　IncrementRotation=相対
Sh.TextFrame.Characters.Text = "AAA"
Sh.TextFrame.Characters.Font.Size = 20
Sh.TextFrame.Characters.Font.Color = vbGreen
Sh.Line.ForeColor.RGB = vbRed
Sh.Fill.Visible = False
Sh.ThreeD.Depth = 20 ' 奥行きの設定
Sh.ThreeD.SetExtrusionDirection msoExtrusionTopLeft '奥行方向
Sh.ThreeD.ExtrusionColor.RGB = vbCyan '3Dの色を設定
Sh.ThreeD.Visible = True
'ShadowFormatの取得
Sh.Shadow.OffsetX = 30 '水平方向
Sh.Shadow.OffsetY = -30 '垂直方向
Sh.Shadow.ForeColor.RGB = vbBlue '影の塗りつぶし
Sh.Shadow.Transparency = 0.5 '透明度
Sh.Shadow.Obscured = True 'True=面,False=線
Sh.Shadow.Visible = True
配列数式、特定の文字を含むものだけ順取得
INDEX($C:$C,SMALL(INDEX(NOT(ISNUMBER(FIND("E",$B$1:$B$100)))*
(NOT(ISNUMBER(FIND("D",$B$1:$B$100))))*10^5+
ROW($B$1:$B$100),),ROW(A1)))
図形倍率
ActiveSheet.Shapes(1).LockAspectRatio = msoFalse
ActiveSheet.Shapes(1).Height = 50#
ActiveSheet.Shapes(1).Width = 150#
ActiveSheet.Shapes(1).LockAspectRatio = msoFalse
ActiveSheet.Shapes(1).ScaleWidth 2!, False
ActiveSheet.Shapes(1).ScaleHeight 0.5!, False
重複削除、RemoveDupulicates の第二引数は Header
- 14 -
VBA系
2016/7/30
リストボックス
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then
'MsgBox Me.ListBox1.List(i)
For i = 0 To objIE.document.Links.Length - 1
'イミディエイトウィンドウに表示
Debug.Print objIE.document.Links(i).href
WORDなど外部Office操作
Dim Word As New Word.Application
Word.Visible = True
Word.Documents.Open "C:\word.docx"
Word.Selection.TypeText Text:="あ"
IEサイズ変更、ズーム
IE.ExecWB 63, 0, CLng(80)
選択条件書式、セレクション
=OR(CELL("col")=COLUMN(),CELL("row")=ROW())
ブックイベントセレクションチェンジへ
Application.ScreenUpdating = True
範囲名の削除
ActiveWorkbook.Names("rng").Delete
赤塗りつぶしフィルター
Range("A1").AutoFilter 1, vbRed, Operator:=xlFilterCellColor '8
リストオブジェクト、テーブル
Set Lst = ActiveSheet.ListObjects.Add(xlSrcRange, _
Range("CA1").CurrentRegion, , xlYes)
- 15 -
VBA系
2016/7/30
開いているアクセスを GetObject から操作
Sub Sample()
Dim Ac As New Access.Application
Do
通常GetObjectも可能
Set ac = GetObject("D:\Work\MyFunc\MyFunc.accdb")
On Error GoTo En
Set Ac = GetObject(, "Access.Application")
MsgBox Ac.CurrentDb.Name
If Ac.CurrentProject.Name = "130704_.accdb" Then
MsgBox "Find!", 64
Call AcFun(Ac)
End If
Ac.Quit
On Error GoTo 0
Loop
En:
MsgBox "Finish", 64
End Sub
Function AcFun(Ac As Access.Application)
Ac.DoCmd.OpenTable "T1"
End Function
コメント追加
Application.DisplayCommentIndicator = xlCommentAndIndicator
With R.AddComment("AAA")
.Shape.TextFrame.Characters.Font.Size = 13
.Shape.Fill.ForeColor.SchemeColor = 5
.Shape.Fill.Transparency = 0.05
.Shape.Line.Weight = 1
.Shape.Line.ForeColor.SchemeColor = 2
.Shape.TextFrame.AutoSize = True
End With
IE_リンク
IE.Document.Links(0).Click
- 16 -
VBA系
2016/7/30
グラフタイトル
With ActiveSheet.ChartObjects(1).Chart
.HasTitle = True
'---グラフタイトル表示
.ChartTitle.Text = "9月度売上" '---タイトル文字列設定
.ChartTitle.Left = 0
.ChartTitle.Top = 100
End With
グラフプロットエリア
ActiveSheet.ChartObjects(1).Chart.PlotArea.Fill.UserPicture Pic
散布図、折れ線マーカー色
With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
v = .Values
For i = 1 To UBound(v)
With .Points(i)
.MarkerBackgroundColor = RGB(255, 0, 0)
.MarkerForegroundColor = RGB(255, 0, 0)
End With
Next i
End With
項目軸・値軸書式設定
With ActiveSheet.ChartObjects(1).Chart
.Axes(xlCategory).TickLabels.Font.Size = 15
.Axes(xlValue).TickLabels.Font.Size = 15
.Axes(xlValue).TickLabels.Font.Color = 255
.Axes(xlValue).TickLabels.NumberFormatLocal = "0""円"""
End With
散布図、X,Y軸設定
With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
.Values = Range("B3:B5")
'Y_値
.XValues = Range("C3:C5") 'X_カテゴリ
End With
- 17 -
VBA系
2016/7/30
Source data range
MsgBox ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Formula
列系追加
ActiveSheet.ChartObjects(1).Chart _
.SeriesCollection.Add Range("C1:C10")
データラベル表示
With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Points
For i = 5 To .Count Step 5
With .Item(i)
.HasDataLabel = True
'dataラベル表示
.DataLabel.Interior.Color = 255 '色指定
.DataLabel.Font.Size = 15
'Fontサイズ変更
End With
Next i
End With
値軸最大値・最小値
.Axes(xlValue).MinimumScale = WorksheetFunction.Max(Columns(2))
.Axes(xlCategory).MinimumScale = WorksheetFunction.Min(Columns(3))
Value2 プロパティでシリアル値
MsgBox Range("A1").Value2
配列範囲の選択
Ar(0) = "B1"
Ar(1) = "B4"
Ar(3) = "$C$8"
Range(Join(Ar, ",")).Select
Instr
(1, 2, 3, 4) = (Start, String1, String2, Comp)
第一引数は省略可能
MsgBox InStr(3, "上京下京中京", "京")
MsgBox InStr("上京下京中京", "京")
- 18 -
VBA系
2016/7/30
Intersect
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("B2:C5")) Is Nothing Then MsgBox "B2:C5"
Resize
MsgBox Range("B2").Resize(3, 1).Address = "B2:B4" = Resize(3)
MsgBox Range("B2").Resize(3, 2).Address = "B2:C4"
画面位置
ActiveWindow.ScrollRow = 30
ActiveWindow.ScrollColumn = 30
Application.Goto Reference:=Range("C20"), Scroll:=True
複数セル選択
Union(Range("A2:B4"), Range("C2:D3"), Range("F:F")).Select
Set Rng = Range("B2:C3")
Set Rng = Union(Rng, Columns(5))
Rng.Select
セルの数式空白
If Range("B1") = "" Then MsgBox "空白"
If IsEmpty(Range("B1")) Then MsgBox "Empty"
数式空白含まず
チェンジイベント、Undo
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then
MsgBox "Exclusion"
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
◆ Undo × 2 ⇒ 再度
SpecialCells
Cells.SpecialCells(xlCellTypeFormulas).Select
Cells.SpecialCells(xlCellTypeFormulas, 2).Select
1=数値, 2=文字列, 3=数値 and 文字列
Cells.SpecialCells(xlCellTypeBlanks).Select
- 19 -
VBA系
2016/7/30
数式非表示
Cells.SpecialCells(xlCellTypeFormulas).FormulaHidden = True
ActiveSheet.Protect
複数セル範囲エリア
Set Rng = Range("A1:B2, C1:D3, F3:F10")
Rng.Areas(2).Select
MsgBox Rng.Areas.Count
特定セル内変換
Application.FindFormat.Interior.Color = vbYellow
Range("A:A").Replace _
What:="京", _
Replacement:="◆", _
LookAt:=xlPart, _
MatchCase:=True, _
MatchByte:=True, _
SearchFormat:=True
ペースト加算
Columns("C:C").PasteSpecial Paste:=xlValues, Operation:=xlAdd
セル挿入で選択セル不変
Range("C2").Select
Selection.Insert xlShiftDown
⇒ 挿入後選択セルはC2
セル範囲の開始・終了行列
開始行
MsgBox Rng.Row
終了行
MsgBox Rng.Rows(Rng.Rows.Count).Row
開始列
MsgBox Rng.Column
終了列
MsgBox Rng.Columns(Rng.Columns.Count).Column
セル範囲
Rng.Name = "烏丸御池"
Rng.Name = ActiveSheet.Name & "!烏丸御池"
Range("烏丸御池").Select
ActiveWorkbook.Names("烏丸御池").Delete
MsgBox Names("四条烏丸").RefersToLocal
= セル名範囲
- 20 -
VBA系
2016/7/30
セルロック
Range("A1").Locked = False
セル範囲内指定、Intersect
Intersect(Range("E2,D5,G7").EntireRow, _
Range("E1").CurrentRegion).Interior.Color = vbYellow
MsgBox ActiveCell.Next
タブキーでの移動、Protect 中でも同様、逆は Previous
数式かどうか
MsgBox ActiveCell.HasFormula
MsgBox ActiveCell.HasArray
= 配列数式時
ActiveCell.FormulaArray = ActiveCell.Formula
Array数式修正
コメントセル判定
MsgBox TypeName(ActiveCell.Comment)
"Comment" or "Nothing"
連続範囲数
MsgBox Selection.Areas.Count
Selection.Areas(2).Select
セル範囲（Range() ）の中身は255文字まで
セル範囲の格納
Set Rng = Union(Rng, R)
他アプリ操作
Dim Wd As New Word.Application
For Each c In Wd.Tasks
If c.Name Like "Microsoft Access*" Then c.Close
Next c
非アクティブシートのセルを選択
Application.Goto Sheets("Sheet2").Range("B3")
漢字判定
Case Is >= "亜"
- 21 -
VBA系
2016/7/30
幅狭セル
For Each Rng In Selection
If IsError(Rng) Then
MsgBox "Error!", , Rng.Address
Else
If Rng.Value <> Rng.Text And _
Left(Rng.Text, 1) = "#" Then
MsgBox "Column Shrink", , Rng.Address
End If
End If
Next Rng
◆＃＃＃記号は数値セルのみ
セルに目印
ActiveCell.ID = "kyouto"
ブックを閉じるまで、非保存
セル絶対参照変換
ConvertFormula(Formula, FromReferenceStyle,
ToReferenceStyle, ToAbsolute, RelativeTo)
R = Application.ConvertFormula(R.Formula, xlA1, xlA1, xlAbsolute)
R = Application.ConvertFormula(R.Formula, 1, 1, 2)
◆第三引数
xlAbsolute
1
$A$1
xlAbsRowRelColumn
2
A$1
xlRelRowAbsColumn
3
$A1
xlRelative
4
A1
数式中の全参照セル
MsgBox ActiveCell.DirectPrecedents.Address
⇒ アクティブシートのみ Vlook範囲含む
特定セルのセル幅を基準に列全体 Autofit
ActiveCell.Columns.AutoFit
ActiveCell.EntireColumns.AutoFit
└ Row は不可
Autofill
ActiveCell.AutoFill Destination:=ActiveCell.Resize(3)
ActiveCell.AutoFill Range("I3:K3")
- 22 -
VBA系
2016/7/30
共通セル範囲
Range("B2:C10 A3:D3").Select
スペース指定
セルのふりがな設定
ActiveCell.Characters(1, 2).PhoneticCharacters = "Pho"
選択範囲数
MsgBox Selection.Count
MsgBox Selection.Areas(1).Count
列アルファベット
n = 222
Str = Cells(1, n).Address(True, False)
MsgBox Left(Str, InStr(Str, "$") - 1)
コメント追加
If TypeName(ActiveCell.Comment) = "Nothing" Then
ActiveCell.AddComment.Text "Comment"
コメント表示
Range("A5").Comment.Visible = False
Address
Address( RowAscolute, ColumnAbsolute, xlReferenceStyle, External
MsgBox ActiveCell.Address(True, True, xlR1C1, True)
└ External ⇒ '[BookName]'Sh!A1
複数ふりがな取得
Str = Application.GetPhonetic("都")
Do While Str <> ""
MsgBox Str
Str = Application.GetPhonetic()
Loop
選択セル外枠
Selection.BorderAround True, xlMedium
◆第二引数以降は省略可能
リストボックスリンク
ActiveSheet.Lst1.LinkedCell = "A3"
- 23 -
ふりがな設定・Visible
VBA系
2016/7/30
With Range("A1").Phonetic
.CharacterType = xlHiragana
.Visible = True
.Font.Size = 12
End With
ブック・シート・セル同時移動
Application.Goto "[BK.xlsm]Sheet1!R1C5"
乱数=Int((最大値 - 最小値 +1 ) * Rnd + 最小値)
重複の無い乱数値の設定
Dim n As Long
Const Max = 12
Const Min = 3
Dim ArBln(Min To Max) As Boolean
Randomize
For i = Min To Max
Do
n = Int((Max - Min + 1) * Rnd + Min)
Loop Until ArBln(n) = False
Cells(i - Min + 1, 1) = n
ArBln(n) = True
Next i
セル結合
Selection.Merge
選択シート数
ActiveWindow.SelectedSheets.Count
濁音判定
Str = Range("A1").Phonetic.Text
Str = StrConv(Str, vbKatakana)
If Len(Str) < Len(StrConv(Str, vbNarrow)) Then MsgBox "濁音"
└ 濁音は半角では1文字
チャートセリエ色
Chart.SeriesCollection(i).Format.Fill.ForeColor.RGB = vbRed
- 24 -
線シャープ挿入
VBA系
2016/7/30
StartR = 2
EndR = 10
With Range(Cells(StartR, "A"), Cells(EndR, "A"))
L = .Left + (.Width) / 2
H = .Top + .Height
Set c = ActiveSheet.Lines.Add(L, .Top, L, H)
c.Border.Color = vbRed
c.Border.Weight = 3
End With
ハイパーリンク
(Anchor, Address, SubAddress, ScreenTip, TexttoDisplay)
Range("A1").Hyperlinks.Add _
Anchor:=Range("A1"), _
Address:="C:\BK.xlsm", _
SubAddress:="T1!A1", _
ScreenTip:="カーソル時", _
TextToDisplay:="セル文字"
ピボットページエリアフィルタクリア、マルチ設定
pv.PivotFields("都道府県").ClearAllFilters
pv.PivotFields("都道府県").EnableMultiplePageItems = True
ピボットページエリア
For i = 0 To ActiveSheet.都道府県.ListCount - 1
If ActiveSheet.都道府県.Selected(i) = False Then _
pv.PivotFields("都道府県") _
.PivotItems(ActiveSheet.都道府県.List(i)).Visible = False
Next
ページエリアの中身
For Each c In pv.PivotFields("都道府県").PivotItems
MsgBox c
Next c
IE Form, Item検索
For Each c In IE.Document.Forms.Item
For Each c In IE.Document.Forms
- 25 -
VBA系
2016/7/30
横棒、縦軸最上段のみデータラベル
k = Chart.SeriesCollection(i).Points.Count
Chart.SeriesCollection(i).Points(k).ApplyDataLabels
Chart.SeriesCollection(i).Points(k).DataLabel.ShowValue = False
Chart.SeriesCollection(i).Points(k).DataLabel.ShowCategoryName = False
Chart.SeriesCollection(i).Points(k).DataLabel.ShowSeriesName = True
IE, Frame操作
Dim FrameC As FramesCollection
Dim HtmlD As HTMLDocument
Set FrameC = IE.Document.Frames
Set HtmlD = FrameC(1).Document
Stop
'★0スタート Frame(30,70) の30ががゼロ、70が1
HtmlD.all.Zipradio.Checked = True
HtmlD.all.btnOk.Click
For Each c In HtmlD.getElementsByTagName("input")
マーカーまとめ
Dim P As Point
Set P = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Points(1)
P.MarkerStyle = xlMarkerStyleCircle
'xlMarkerStyleCircle
丸
'xlMarkerStyleDash
横長長方形
'xlMarkerStyleDiamond ひし形
'xlMarkerStyleNone
マーカー無
P.Format.ThreeD.BevelTopType = msoBevelSoftRound
P.MarkerBackgroundColor = vbRed
'マーカー色
P.Format.Line.ForeColor.RGB = vbBlack
'マーカー線
P.Format.Line.Weight = 0.01
'マーカー線太さ
P.Format.Line.Transparency = 0.25
P.Format.Fill.Transparency = 0.9
P.MarkerSize = 50
P.HasDataLabel = True
'透過性
'マーカーサイズ
'データラベル
P.DataLabel.ShowSeriesName = True
P.DataLabel.ShowValue = True
P.DataLabel.ShowCategoryName = True
P.DataLabel.AutoText = True
'系列名
'Y値
'X値
'オートテキスト
- 26 -
'P.DataLabel.Characters(1, 1).Font.Color = vbRed
VBA系
2016/7/30
P.DataLabel.Format.Fill.ForeColor.RGB = vbYellow
P.DataLabel.HorizontalAlignment = xlLeft
P.DataLabel.Separator = Space(3)
P.DataLabel.Position = xlLabelPositionAbove
'上
P.DataLabel.Position = xlLabelPositionBelow
'下
P.DataLabel.Position = xlLabelPositionCenter
'中央
P.DataLabel.Position = xlLabelPositionLeft
'左
IE
IE.ExecWB 17, 0
'セレクトオール
IE.ExecWB 18, 0
'クリアセレクト
ピボット行列位置移動
pv.PivotFields("F1").PivotItems("B").Position = 3
ソート的な表示順
【パワポマクロ開始】
スライド選択
ActivePresentation.Slides(2).Select
図形選択
ActivePresentation.Slides(2).Shapes("Txt1").Select
図形へテキスト
ActivePresentation.Slides(2).Shapes("Txt1").TextFrame.TextRange.Characters.Text = "京都"
選択図形の一括位置調整
For Each c In ActiveWindow.Selection.ShapeRange
c.Left = 300
Next c
シェイプペースト
PPre.Slides(2).Shapes.Paste
Set Sp = PPre.Slides(2).Shapes(PPre.Slides(2).Shapes.Count)
【パワポマクロ終了】
- 27 -
VBA系
2016/7/30
選択範囲で中央
Range("A1:A3").Select
Selection.HorizontalAlignment = xlCenterAcrossSelection
セル選択確認
If TypeName(Range) Then
If TypeName(Selection) = "Picture" Then
ゼロを非表示
ActiveWindow.DisplayZeros = False
複数セル編集判定
If Target.Count > 1 Then
シートイベントの "Target" はアクティブセルではなく Selection
エリア
Range("A1:A2,C5:D6,E2:G3").Select
MsgBox Selection.Areas(2).Address
HTML改行
style="width: 70px;border: 1px solid #000;word-break: break-all;"
行ごとの一括行挿入
Range("2:2,4:4,5:5").Insert xlShiftDown
⇒ 各列にそれぞれ1行追加、2行目の次、4行目の次
セレクトケースの To 条件
Case "あ" To "ん"
セルの目印に Rng.ID 使用、ブックを閉じると消える
Application.ConvertFormula
①xlA1 ⇒ xlR1C1, ②相対 ⇔ 絶対参照
MsgBox Application.ConvertFormula(Selection.Address, xlA1, xlA1, xlRelative)
xlAbsolute, xlAbsRowRelColumn, xlRelRowAbsColumn, xlRelative
- 28 -
VBA系
2016/7/30
セル範囲まとめ
Range("A1:B10 A3:F3").Select
2範囲の交差範囲
Range("A1", "B3").Select
A1 ～ B3
Resize利用のセルの値移動
With Selection
Range("G1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
ユニーク値の作り方
For i = 1 To 10
Do
'乱数=Int((最大値 - 最小値 +1 ) * Rnd + 最小値)
myNum = Int((10 - 1 + 1) * Rnd + 1)
Loop Until myFlag(myNum) = False
Cells(i, 1).Value = myNum
myFlag(myNum) = True
Next i
ハイパーリンク
Set Hlink = Range("B1").Hyperlinks.Add( _
Anchor:=Range("B2") _
, Address:=ThisWorkbook.FullName _
, SubAddress:="Sheet2!B2" _
, ScreenTip:="ScreenTip")
Hlink.TextToDisplay = "texttodisplay"
Hlink.SubAddress = "Sheet2!B2"
行列 ジャンプからの相違範囲
Set Rng = Range("C1:C20")
Set Rng = Rng.ColumnDifferences(Range("C7"))
Rng.Interior.Color = vbYellow
ジャンプ ⇒ セル選択 ⇒ アクティブ[行 | 列] との相違
⇒ 判定は数式ベース(not 値)
行の場合 ⇒ Rng.RowDifferences(Range("C7"))
(セル範囲).ColumnDifferences(基準値の1セル)
└ (セル範囲)中の値で、基準値の1セル値と異なるセル群, (セル範囲) は×数式, 要値
- 29 -
VBA系
2016/7/30
チェックボックス
With ActiveSheet.CK1
.Accelerator = "a"
'Altキーと同時に (Only Excel)
.Alignment = 1
'0 ⇒ ボタンがテキストの右側に (Only Excel)
.Picture = LoadPicture("C:\Red.jpg")
'フォーム同 (Only Excel)
.TripleState = True
'Null, True, False
MsgBox .Value
End With
'チェック切替えは Value を True or False へ
オプションボタン
With ActiveSheet.Op1
.Accelerator = "a"
'Altキーと同時に (Only Excel)
.Alignment = 1
'0 ⇒ ボタンがテキストの右側に (Only Excel)
.GroupName = "G1"
'グループ化 UF同 (Only Excel)
End With
●以下アクセス
Fm.Op1.Value = True
'切換え = Access
Fm.F1.Value = 0
'F1 = フレームオブジェ名
Fm.F1.Value = 1
'0=無し, 1=Op1, 2=Op2 Selected
Fm.F1.Value = 2
プログレスバー
With ActiveSheet.Progr1
.Max = 100
.Min = 10
.Value = 30
.Shadow = True'(Only Excel)
.Left = 30
MsgBox .TopLeftCell.Address'(Only Excel)
End With
テキストボックス リンク
ActiveSheet.OLEObjects("Txt1").LinkedCell = "Sheet1!E2"
セル ⇔ OLEテキストボックス
Dim c As OLEObject
Set c = ActiveSheet.OLEObjects("Txt1")
- 30 -
VBA系
2016/7/30
カレンダー
FM2.Calendar1.Year = 2010
FM2.Calendar1.Month = 12
FM2.Calendar1.Day = 13
'FM2.Calendar1.Today
FM2.Calendar1.DayLength = 3
'0=水曜日, 1=水, 2=Wendnesday, 3=Wed
FM2.Calendar1.MonthLength = 3
'0=12月, 1=12, 2=December, 3=Dec
'値出力
Private Sub Calendar1_Click()
Range("E2") = Me.Calendar1.Value
'テキストボックス KeyDown を使用した年月日変動
'コントロール名 = Calendar1 の前提
'アクセスでもコードは全く同じだた1行目 Private ～ が相違
Private Sub TextBox1_KeyDown( _
ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
If KeyCode <> vbKeyUp _
And KeyCode <> vbKeyDown _
And KeyCode <> vbKeyLeft _
And KeyCode <> vbKeyRight Then Exit Sub
Dim D As Long
D = Me.Calendar1.Day
Select Case KeyCode
Case vbKeyUp
Me.Calendar1.Year = Me.Calendar1.Year + 1
Case vbKeyDown
Me.Calendar1.Year = Me.Calendar1.Year - 1
Case vbKeyRight
Me.Calendar1.Month = Me.Calendar1.Month + 1
Case vbKeyLeft
Me.Calendar1.Month = Me.Calendar1.Month - 1
End Select
Me.Calendar1.Day = D
End Sub
- 31 -
マルチページ
VBA系
2016/7/30
【クラスモジュール】
'/*************************************************************/
Public WithEvents Cmd0 As MSForms.CommandButton
Public WithEvents Txt0 As MSForms.TextBox
Public WithEvents Lbl0 As MSForms.Label
Public WithEvents Lst0 As MSForms.ListBox
Public WithEvents Tgl1 As MSForms.ToggleButton
'/*************************************************************/
Private Sub Txt_Change()
Me.Lbl.Caption = Me.Txt.Value
End Sub
'/*************************************************************/
Private Sub Tgl1_Click()
If Tgl1 = True Then
Me.Tgl1.BackColor = vbCyan
Me.Tgl1.Caption = Me.Tgl1.Value
Else
Me.Tgl1.BackColor = vbYellow
Me.Tgl1.Caption = Me.Tgl1.Value
End If
End Sub
【標準モジュール】
モジュール[CTRL_Set]でクラスモジュール間をセット
モジュール[DropClass]で解放
モジュール[OLEobj_Sample]は標準モジュールからのサンプル
クリック操作は上記クラスモジュール内で
Dim Cls As New Class2
'/*************************************************************/
Sub CTRL_Set()
'大前提セット
With Sheets("OLE").OLEObjects("Mlti1").Object.Pages("Cap1")
Set Cls.Cmd0 = .Controls("Btn1")
Set Cls.Txt0 = .Controls("Txt1")
Set Cls.Lbl0 = .Controls("Lbl1")
Set Cls.Lst0 = .Controls("Lst1")
End With
- 32 -
VBA系
2016/7/30
Set Cls.Tgl1 = _
Sheets("OLE").OLEObjects("Mlti1").Object _
.Pages("Cap2").Controls("Tgl1")
MsgBox "Finish!", 64
End Sub
'/*************************************************************/
Sub OLEobj_Sample()
'標準モジュールからのマルチ操作
Dim Sh As Worksheet
Set Sh = Sheets("OLE")
'●マルチページについて
Dim OLEm As OLEObject
Set OLEm = Sh.OLEObjects("Mlti1")
OLEm.Left = 30
'左 他トップ,幅, 高さ
OLEm.Shadow = True
'影
'MsgBox OLEm.TopLeftCell.Address
'トップレフトセル
'OLEm.Visible = Not OLEm.Visible
'マルチオブジェ全体の表示
'●マルチページオブジェクト
Dim M As MSForms.MultiPage
Set M = Sh.OLEObjects("Mlti1").Object
'●ページについて
Dim P As MSForms.Page
'ページからのインテリ用
Set P = Sh.OLEObjects("Mlti1").Object.Pages("Cap1")
P.Caption = "Cap1"
'タグ表示
P.Name = "Cap1"
'コントロール名
P.Index = 0
'タグボタン位置, 0開始
P.Zoom = 100
'ズーム（絶対, not 相対）
└ ページはゼロスタート ⇒ Pages(0) ⇒ 一番左のページ
'●内部コントロール
Dim Lst1 As MSForms.ListBox
Set Lst1 = Sh.OLEObjects("Mlti1").Object.Pages("Cap1").Controls("Lst1")
- 33 -
VBA系
2016/7/30
Dim Ar(2, 1) As String
Ar(0, 0) = "0-0": Ar(0, 1) = "0-1"
Ar(1, 0) = "1-0": Ar(1, 1) = "1-1"
Lst1.List = Ar
'リスト配列セット
Lst1.ColumnCount = 2
'カラムカウント
Lst1.BoundColumn = 2
'バウンドカラム
Lst1.ColumnWidths = "1.5cm;1.5cm"
'列幅
Lst1.AddItem "2-0,2-1"
'追加
MsgBox Nz(Lst1.Value, "")
'選択値
リストボックス リストへバリアント型2次配列可能
DoEvents
MsgBox "Finish!", 64
End Sub
'/*************************************************************/
Sub DropClass()
'シートマルチ解放
Set Cls = Nothing
End Sub
◆ページ変更
cls.Multi1.Value = 3
- 34 -
VBA系
2016/7/30
コンボとリストボックス
リスト参考
With Me.Lst1
.RowSource = ""
'ソース排除
.RowSource = "B5:C10"
'ソース
.ColumnCount = 2
'カラム数
.BoundColumn = 2
'バウンドカラム
.ColumnWidths = "2cm;2cm" '列幅
.ColumnHeads = True
.MultiSelect = 1
'先頭行
'マルチセレクト
.ControlTipText = "AAA"
.ControlSource = "A1"
.ListStyle = 1
.Font.Size = 12
'ヒントテキスト
'リンクセル
'チェック付
'フォントサイズ
End With
- 35 -
VBA系
2016/7/30
ピボットいろいろ
Scl1Name = フィールド名
'スライサー追加
Set Slc1 = ActiveWorkbook.SlicerCaches.Add(pv, Slc1Name) _
.Slicers.Add(ActiveSheet, , Slc1Name, Slc1Name, L, T, 100, 200)
CtrolName Caption
オブジェ名, キャプ名は自由に命名
スライサー高さ, 色や位置, キャプション
Slc1.RowHeight = 15
行高
Slc1.ColumnWidth = 80
カラム幅
Slc1.Style = "SlicerStyleLight2"
スタイル
Slc1.Top = 10
高さ
Slc1.Left = 30
左
Slc1.Caption = "AAA"
キャプション
Slc1.NumberOfColumns = 2
カラム数
Slc1.SlicerCache.SlicerItems("滋賀県").Selected = False
選択
'ピボット作成
Const pvName As String = "pv"
Const DestiPv As String = "E2"
Const SourceRng As String = "A50:C60"
Const FromSheet = "Sheet1"
Const ToSheet = "Sheet2"
Set pv = ActiveWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=Sheets(FromSheet).Range(SourceRng)).CreatePivotTable( _
TableDestination:=Sheets(ToSheet).Range(DestiPv), TableName:=pvName)
'前年同日日など --- 日付グループ設定後条件
Dim pvf As PivotField
pvf = pv.PivotFields("_Num1")
pvf.Calculation = xlPercentOf
pvf.BaseField = "年"
pvf.NumberFormat = "0.0% "
グループ Data型
pvF.DataRange(1, 1).Group _
Periods:=Array(False, False, False, True, True, True, True)
pv.PivotFields("月").Orientation = Empty
(Empty = xlHidden)
- 36 -
VBA系
2016/7/30
'数値型
pv.PivotFields("Num1").LabelRange.Offset(1).Ungroup
pv.PivotFields("Num1").LabelRange.Offset(1).Group Start:=1000, End:=1300, By:=200
pv.PivotFields("Num1").PivotItems("=1000").Visible = False
'ページフィールド
pv.PivotFields("地区").ClearAllFilters
'全表示
pv.PivotFields("地区").EnableMultiplePageItems = True
'複数選択
pv.PivotFields("地区").PivotItems("京都").Visible = True
'特定選択
'ピボットいろいろ
pv.TableStyle2 = "PivotStyleLight22"
'スタイル
pv.ShowTableStyleRowStripes = True
'行ストライプ
pv.ShowDrillIndicators = False
'ドリル表示
pv.MergeLabels = True
'ラベル結合
pv.RowAxisLayout xlTabularRow
'表形式
pv.RepeatAllLabels xlRepeatLabels
'繰返し表示
pv.ColumnGrand = False
pv.RowGrand = False
'列合計表示
'行合計表示
pv.PivotFields("合計 / F2").LabelRange.Offset(1).Sort Order1:=1
'並び替え
Set pv = ActiveSheet.PivotTables(1)
Set pvf = pv.PivotFields("合計 / F2")
pvf.DataRange(1, 1).Sort Order1:=2
↓　以下は不可なので、1度 pvf に格納。
pv.PivotFields("合計 / F2").DataRange(1, 1).Sort Order1:=1
'データ通常追加
pv.AddDataField pv.PivotFields("Num1"), "見出し", xlSum
pv.AddFields _
RowFields:=Array("地区", "季節"), _
ColumnFields:="Date", _
PageFields:="Str"
'ピボット範囲変更
Set Rng = Range("A50:D100")
pv.ChangePivotCache ActiveWorkbook.PivotCaches.Create(xlDatabase, Rng)
- 37 -
VBA系
2016/7/30
'数式フィールド追加
pv.CalculatedFields.Add _
Name:="CalcField", _
Formula:="=Num1 / 10", _
UseStandardFormula:=True
'単発オリエンテーション
pv.PivotFields("CalcField").Orientation = xlDataField
'ピボットオプション
pv.PivotFields("CalcField").Caption = "AAA"
'pvリスト キャプション
pv.PivotFields("合計 / CalcField").Caption = "aaa"
'pv上キャプション
pv.PivotFields("aaa").Calculation = xlPercentOfColumn '基準値比率
pv.PivotFields("aaa").NumberFormat = "0.0% "
pv.PivotFields("AAA").Delete
'フォーマット
'削除はリスト名で
データ開始セル
pv.DataBodyRange(1, 1).Address
pv.DataBodyRange(1, 1).Address
pvf.DataRange(1, 1).Address
範囲変数のシート名
(単純なパレント利用)
Set Rng = Sheets("Sheet1").Range("B2:C3")
MsgBox Rng.Parent.Name
VBEで CTRL + Tab でモジュール切替え
- 38 -
VBA系
2016/7/30
不一致クエリ
Select * From A Where Not Exists(
Select * From B Where A.企業ID = B.企業ID)
◆acで Exists 可能
Select A.* From A Left Join B On A.企業ID = B.企業ID
Where B.企業ID Is Null
Select * From A
Except 演算子
Except Select * From B
(ac不可, 左外部不一致クエリ)
Select 企業id, num From A
右はA, B
Except
反転
Select 企業id, num From B
オペランドの左のクエリでは返されるが、右のクエリでは返されない個別の値を返します
└ オペランド = 演算の対象となる値や変数, 被演算子
└ 「A+10」という式では、「A」と「10」がオペランドで、「+」がオペレータ
Intersect 演算子
(ac不可, 全列内部クエリ)
Select 企業id, num From A
Intersect
反転は関係無し
Select 企業id, num From B
オペランドの左右両方のクエリによって返される個別の値を返します
Exリストボックス
Dim Lst1 As MSForms.ListBox
Set Lst1 = Sh.OLEObjects("Lst1").Object
Column(列, 行)
Lst1.Column(0, 0) = F1
Lst1.Column(0, 1) = A1
Lst1.Column(0, 2) = A2
Lst1.Column(1, 2) = 11
For i = 0 To Lst1.ListCount - 1
Lst1.Selected(i) = 理論値
Exアドレス引数
①RowAbsolute, ②ColumnAbsolute, ③ReferenceStyle, ④External, ⑤RelativeTo
①②理論値 ⇒ $A$1, ③xlA1 or xlR1C1, ④理論値 ⇒ [Book1]Sheet1!A1, ⑤相対参照
- 39 -
VBA系
2016/7/30
Cn 開いているか
Cn.State
adStateClosed
0 【既定値】オブジェクトが閉じていることを示します。
adStateOpen
1 オブジェクトが開いていることを示します。
adStateConnecting
2 オブジェクトが接続中であることを示します。
adStateExecuting
4 オブジェクトがコマンドを実行中であることを示します。
adStateFetching
8 オブジェクトの行を取得中であることを示します。
アクセス クエリ追加
Cn.Open CnStrAc
Set Rs = Cn.Execute("Create View Q1 As Select * From T1;")
Set Rs = Cn.Execute("Drop View Q1")
Set DB = CreateObject("DAO.DBEngine.120").Workspaces(0) _
.OpenDatabase("C:\Users\Takehiro Yamada\Desktop\Test\0807\DB.accdb")
DB.CreateQueryDef "Q1", "Select * From T1"
DB.Close
Cn.Open CnStrAc
Cat.ActiveConnection = Cn
Cmd.CommandText = "Select * From T1"
Cat.Views.Append "Q1", Cmd
Cn.Close
【Ac通常手動クエリで in 'パス' 操作可】
└テーブル作成も可
アクセステーブルをエクセルシートへエクスポート
Cn.Execute "Select * Into [Sheet1] In '"D:Sample.xlsx' 'Excel 8.0;' From Table1;"
(xlシート名に$ダラー不要, 新シートは存在していないこと, ブックは必ずクローズ済)
(ac通常クエリ手動操作からでも in 'パス' 指定で可能)
エクセルシートをアクセステーブルへインポート
SQL = "Select * Into T1 From [Sh1$A1:C3] In 'D:\Book1.xlsm' 'Excel 8.0;'"
アクセスから空エクセル利用（GetObject以外の操作）
Dim Ex As New Excel.Application
Ex.Visible = True
Ex.Workbooks.Add
DAOのアクセスレコードセットをエクセルに CopyFromRecordset 可能
- 40 -
VBA系
2016/7/30
アプリフォーカス
FindWindow, SetForegroundWindow のAPI利用
myHwnd = FindWindow("OMain", vbNullString)
If myHwnd = 0 Then
MsgBox "Nothing!", 64
Else
SetForegroundWindow myHwnd 'フォーカス
End If
アクセスインポート、保存済みインポート方法の実行
DoCmd.RunSavedImportExport "保存済みインポート方法"
アクセス・エクセルボタンにマクロセット
Forms!F1.Btn.OnClick = "=aaa()"
ActiveSheet.Shapes("ab").OnAction = "aaa"
(ex ActiveX Controlsは不可)
アクセス、閉じるときに最適化標準設定
レコードセットから型取得
Rs(i).Type
ADO, DAO 共に可能
【定数取得、テーブルから】
DB.TableDefs("ALLData") _
.Fields("ｺｰﾄﾞAAA").Type
(色々指定sqlからのRsからType
取得可能, 戻り値は⇒整数)
ピボット範囲変更
pv.SourceData = Sheets("Sheet1").Range("A1:D7").Address(True, True, xlR1C1, True)
- 41 -
VBA系
2016/7/30
ピボットデータフィールドを非表示
For Each c In pv.DataFields
c.Orientation = xlHidden
'
pv.PivotFields(c.Name).Orientation = xlHidden
Next c
検索ボックス
基本は部分一致
?ワイルド（1文字）可能
完全一致はダブルクォートくくり
1回前保存のバックアップ
同フォルダにバックアップファイル作成
(ファイル保存時のツール⇒全般オプション)
ADODB.Stream
.State
開いているか（1)、閉じているか（0）
TypeName(value)="String" '文字列型かどうか
IE
D.Title
IE.statusText = "京都"
D.bgColor = "Cyan"
(単純に ドキュメントの bgColor = だけで可)
D.characterSet
D.cookie
D.domain
D.GetElementByID
sなし
D.GetElementsBy
ClassName
Name
TagName
TagNameNS
D.Images(2).Src
D.LastModified
- 42 -
VBA系
2016/7/30
アクセスクロス集計のテーブル化
SQL = _
テーブル化後を通常Rsとして再利用可
"Select * Into NewTable " & _
次の親セレクトは新フィール
"From [TransForm Count(Num) Select Txt " & _
ド名はブラケットでくくるか
"From T1 Group By Txt Pivot kDate " & _
別名を付与した方が安全
"In (#2014/03/03#, '2014/02/02')]. As T"
'◆パーレンではなくブラケット
'◆最後の.は必須
'◆サブクエリ名も必須
アクセスクエリ作成
Create View As ViewName As
純選択クエリ
Create Procedure As ProcName As
それ以外のクエリ
ADOX.Catalog から回す時も同様
Dim objView As Procedure
objview.Command.CommandText
└ Cat.Procedures から、SQL内容取得
アクセスクロス集計条件可能
TransForm IIF(IsNull(Count(F1)), 999, Count(F1))
ADO, 強制テキスト扱い
;Extended Properties="Excel 8.0;HDR=②; [IMEX=1;]";
アクセスロールバック
Dim Wsp As DAO.Workspace
Set Wsp = DBEngine.Workspaces(0)
Wsp.BeginTrans
CurrentDb.Execute "Update T1 Set Txt = 'BBB' Where Num = 12;"
Wsp.CommitTrans
'Wsp.Rollback
※ ○CurrentDb.Execute,
×Docmd.RunSQL
ADO処理実行数
Connection.Execute CommandText [, RecordsAffected] [, Options]
RecordsAffected に数値型変数をセット、その変数に処理レコード数が返る
ADO, エクセル範囲指定インサート
Cn.Execute "Insert Into [Sheet5$B1:D20](f2, f3) Values('z1', 'zz1');", ReCnt
Hdr=No, 上記の場合C列に追加（B列から数えて2列目）
- 43 -
ADO, エクセルなど、カンマ区切りは文字列扱い
VBA系
2016/7/30
Vnt = Array("'aa'", "'bb'")
Cn.Execute "Insert Into [Sheet5$B1:D20](f2, f3) Values(" & Join(Vnt, ",") & ");", ReCnt
ADOでアクセスクエリSQL取得
Cat.ActiveConnection = Cn
For Each Proc In Cat.Procedures
MsgBox Proc.Command.CommandText
アクセスステータスバー
Application.SysCmd acSysCmdSetStatus, "京都吉祥院"
Application.SysCmd acSysCmdClearStatus
- 44 -
VBA系
2016/7/30
WorkSpaces
DBEngine.CreateWorkspace(Name, User Name, PassWord, [Type]
Set Wsp = DBEngine.CreateWorkspace("", "Admin", "")
Set DB = Wsp.OpenDatabase(CurrentProject.Path & "\DB2.accdb", False, False)
Wsp.BeginTrans
SQL = "Create Table T2(F1 Counter(1) Primary Key, F2 Long Not Null)"
DB.Execute SQL, dbFailOnError
Wsp.CommitTrans
Dim Ac As New Access.Application
'Wsp.Rollback
Dim DB As DAO.Database
Wsp.Close
Dim Wsp As DAO.Workspace
Set Wsp = Nothing: Set DB = Nothing
Ac.OpenCurrentDatabase CurrentProject.Path & "\DB2.accdb", False
Ac.Visible = True: Ac.Quit acQuitSaveNone: Set Ac = Nothing
【Acから他のAc操作可能】
⇒ OpenDatabase(Name{fullPath}, Options{排斥=規定False}, ReadOnly{規定=False}, Connect{接続文字})
DAOからのSQL, Option
DB.Execute SQL, Option
Option = dbFailOnError ⇒ エラー時ロールバック （定数は128）
エクセルピボット
For Each pvi In pv.PivotFields("Prefec").PivotItems
pvi.RecordCount
pvi.Visible
MsgBox pvf.EnableMultiplePageItems
ページエリアでない場合はFalse, 選択していなくてもエラーにならない
MsgBox pv.PivotFields("合計 / 4月").Orientation
⇒ 4 = DataField
MsgBox pv.PivotFields("4月").Orientation
⇒ エラー
pv.AddDataField pv.PivotFields("4月"), "4月合計", xlSum
⇒ OK
pv.AddDataField pv.PivotFields("4月"), "4月", xlSum
⇒ 重複フィールド名エラー
pvf.Function = xlAverage
'-4106
pvf.Function = xlMax
'-4136
pvf.Function = xlCount
'-4112
pvf.Function = xlSum
'-4157
pvf.Function = xlCountNums
'-4113
pvf.Function = xlProduct
'-4149
pv.DataFields("データの個数 / 5月").Function ⇒ 実際にはインデックス数値利用
pv.DataFields.Count
For Each pvf In pv.DataFields
- 45 -
VBA系
2016/7/30
グラフ詳細
Set Ct = ActiveSheet.ChartObjects(1).Chart
Set Se = Ct.SeriesCollection
Set P = Se(1).Points(1)
'線のスタイルのみ
Se(i).Border.Weight = xlThick
'3pt
Se(i).Border.Weight = xlHairline
'0.25pt
Se(i).Border.Weight = xlMedium
'2pt
Se(i).Border.Weight = xlThin
'1pt
Se(i).MarkerStyle = xlMarkerStyleStar
Se(i).MarkerSize = 10
Se(i).MarkerBackgroundColor = vbRed
Se(i).MarkerForegroundColor = vbWhite
Se(i).Format.Line.Weight = 5
Se(i).Format.Line.ForeColor.RGB = vbBlue
Se(i).Format.Line.BackColor.RGB = vbGreen
P.MarkerStyle = xlMarkerStyleDiamond
P.MarkerSize = 15
P.MarkerBackgroundColor = vbRed
P.MarkerForegroundColor = vbCyan
P.Format.Line.Weight = 5
P.Format.Line.ForeColor.RGB = vbBlue
P.Format.Line.BackColor.RGB = vbGreen
ADODB.Streamからのテキスト取得
'objADOS.Charset = "shift-jis"
objADOS.Charset = "UTF-8"
objADOS.Open
objADOS.LoadFromFile Path & "TestA.csv"
objADOS.Position = 0
Open Path & "Result.csv" For Output As #1
Print #1, objADOS.ReadText
Close #1
objADOS.Close
Set objADOS = Nothing
- 46 -
VBA系
2016/7/30
Exエラー範囲合計
=SUMIF(A1:A10,"<"&10^10)
シェイプペースト
PPre.Slides(2).Shapes.Paste
Set Sp = PPre.Slides(2).Shapes(PPre.Slides(2).Shapes.Count)
リボン最小化
If Application.CommandBars.GetPressedMso("MinimizeRibbon") = False Then _
Application.CommandBars.ExecuteMso "MinimizeRibbon"
Ac, Ex, PP 共に可能
パワーポイントの横ペイン表示設定
Dim ppPAry(0) As PowerPoint.Presentation
Set ppPAry(0) = GetObject(ThisWorkbook.Path & "\VBA.pptm")
ppPAry(0).Application.Visible = msoTrue
ppPAry(0).Windows(1).Activate
ppPAry(0).Windows(1).ViewType = ppViewSlide
非表示
ppPAry(0).Windows(1).ViewType = ppViewNormal
ノーマル表示
└ 定数は整数
Ex図形挿入と図形操作
Set xlSp = xlSh.Shapes.AddPicture( _
Filename:=P & ".jpg", _
LinkToFile:=msoTrue, _
SaveWithDocument:=msoFalse, _
Left:=Range("B2").Left, _
Top:=Range("B2").Top, _
Width:=20, _
Height:=20)
xlSh.ShapexlSp.SelectAll
xlSp.LockAspectRatio = msoTrue
Selection.Group
xlSp.Height = 100
Set xlSp = xlSh.Shapes(xlSh.ShapexlSp.Count)
xlSp.Cut
xlSp.Name = "Group1"
Range("B3").PasteSpecial
xlSp.Cut
Range("C2").PasteSpecial
【ピクチャ又はOLEオブジェ】
xlSp.ScaleHeight 1, msoTrue
Factor(第一引数)= 倍率浮動小数
xlSp.ScaleWidth 2.5, msoTrue
RelativeToOriginalSize(第二引数)= 対オリジナルサイズ
- 47 -
Acモジュールの実行
exは開いていれば実行可能
Dim Ac As New Access.Application
VBA系
2016/7/30
xlApp.Run 又は xlBK.Application.Run
Ac.OpenCurrentDatabase P, False
第二引数はモジュール名のみ(非パス)
Ac.Visible = True
Ac.Run "GetTime"
なおステップイン可
Ac.Run "GetTime2", "京都"
Sub GetTime()
Function GetTime2(Str As String)
MsgBox Now
MsgBox Str & vbNewLine & Now
End Sub
End Function
Private Function は不可
DoCmd.RunMacroはオブジェクト一覧にある「マクロ」を実行するためのもの
Ex=xlBK.Application.Run "SampleFuncStr", "京都"
AcDB自体の作成
Dim Cn As New ADODB.Connection
Dim Cat As New ADOX.Catalog
Dim ExecCnt As Long
Dim CnStr As String
CnStr = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source="
CnStr = CnStr & D:\Test.accdb"
Cat.Create CnStr
Set Cn = Cat.ActiveConnection
Cn.Execute "Create Table T1(F1 Long, F2 Counter(1));", ExecCnt
Cn.Execute "Insert Into T1(F1) Values(10);", ExecCnt
Set Cn = Nothing
Acコントロール移動
Me.List1.Move Left, Top, Width, Height
Twip指定 ⇒ 1cm = 567
1Inch = 1440twip = 2.54cm ⇒ 1cm = 567twip
Twentieth of an Inch Point
Acリストボックス、マルチ選択
DoCmd.OpenForm "F1", acDesign
デザインで指定 ⇒ Save
Fm.Controls("Lst1").MultiSelect = 1
1 = クリックマルチ選択、 2 = シフトマルチ選択
- 48 -
VBA系
2016/7/30
配列渡し
v = Ar
Call Test2_2(Ar)
Call Test2_2(v)
Function Test2_2(ByRef Ar() As String)
Function Test2_2(ByVal Ar As Variant )
Dim i As Long
【以下全く同様】
Dim v As Variant
For i = LBound(Ar) To UBound(Ar)
MsgBox Ar(i)
Refの場合のみ参照渡し
Ar(i) = Ar(i) & "京都"
Next i
For Each v In Ar
MsgBox v
いづれでも値渡し扱い
v = v & "滋賀"
Next v
【2次配列可能】
End Function
【バリアントFor順 = 1次 ⇒ 2次】
シェル系
'※ 外部参照 Windows Script Host Object Module
Dim WSHnet As New IWshRuntimeLibrary.WshNetwork
Dim WSH As New IWshRuntimeLibrary.WshShell
Set WSHnet = CreateObject("Wscript.Network")
Set WSH = CreateObject("Wscript.Shell")
MsgBox WSHnet.ComputerName
MsgBox WSHnet.UserName
MsgBox WSHnet.UserDomain
MsgBox WSH.SpecialFolders("DeskTop")
WSH.Popup "Text", 3, "Title", vbInformation + vbYesNo
WSH.Run "D:\DB\csv1.csv"
'※外部参照 Microsoft Shell Controls And Automation
Dim Shel As New Shell32.Shell
Set Shel = CreateObject("Shell.Application")
Shel.UndoMinimizeALL
Shel.MinimizeAll
'全ウィンドウ最小化から復元
'全ウィンドウ最小化
Shel.ShutdownWindows
'シャットダウンっぽい
Shel.TileHorizontally '全ウィンドウ横表示っぽい
Shel.TileVertically
'全ウィンドウ並べ表示っぽい
'For Each c In Shel.Windows
- 49 -
VBA系
2016/7/30
Mail
Dim oApp As New Outlook.Application
'Dim myNameSpace As Outlook.Namespace
Dim SubFol As Outlook.Folder
Dim mITEM As Outlook.MailItem
MAPI =
Dim i As Long
Messaging Application Program Interface
'受信ボックス内サブフォルダ
With oApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For Each SubFol In .Folders
MsgBox SubFol.Name
If SubFol.Items.Count > 0 Then
For i = 1 To SubFol.Items.Count
Set mITEM = SubFol.Items(i)
Stop
MsgBox mITEM.Body
本文
MsgBox mITEM.cc
MsgBox mITEM.BCC
'
mITEM.Attachments.Item(1).SaveAsFile "FullPath"
MsgBox mITEM.SenderName
MsgBox mITEM.SenderEmailAddress
MsgBox mITEM.Size
MsgBox mITEM.Subject
MsgBox mITEM.To
MsgBox mITEM.BodyFormat
Next i
End If
Next SubFol
End With
Set oApp = Nothing
Set SubFol = Nothing
Set mITEM = Nothing
MsgBox "Finish!", 64
- 50 -
VBA系
2016/7/30
VBE操作
'''コード行追加
'CodeModule.InsertLines(line, code)
'With ThisWorkbook.VBProject.VBComponents("Module1").CodeModule
'
.InsertLines 7, vbTab & "Debug.Print Now()"
'End With
'''コード行削除
'CodeModule.DeleteLines (startline [, count])
' └count既存値 = 1 = 指定スタートラインから1行
'
With ThisWorkbook.VBProject.VBComponents("Module" & i).CodeModule
'
.DeleteLines 1, .CountOfLines
'
.AddFromString Join(vntAry, vbNewLine)
'
'既存コード削除
'追加
End With
'''コード置換
'CodeModule.ReplaceLine(line, code)
'''モジュール行数取得
'MsgBox ThisWorkbook.VBProject.VBComponents("Module1").CodeModule.CountOfLines
'''VBEカウント
'MsgBox Application.VBE.VBProjects.Count
'''VBEファイル名
'MsgBox Application.VBE.VBProjects(2).Filename
'''モジュール名
'MsgBox Application.VBE.VBProjects(2).VBComponents("Module2").Name
'''VBEプロジェクト, VBコンポネント（各モジュール）, 各モジュールのコード本体
'With Application.VBE.VBProjects(2).VBComponents
'
For i = 1 To .Count
'
MsgBox .Item(i).Name
'
With .Item(i).CodeModule
'
'
'
v = .Lines(1, .CountOfLines)
'ThisWorkBook, Module1など
'コード本体
End With
Next i
'End With
- 51 -
VBA系
2016/7/30
'''コードモジュールまとめ
'With Application.VBE.VBProjects(2).VBComponents("Module2").CodeModule
'
v = .Lines(1, .CountOfLines)
'
''テキストからモジュール追加
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'コード本体（モジュール全体）
.AddFromFile Filename:="C:\Code.txt"
''文字列からモジュール追加, 追加位置は宣言部分の次行
.AddFromString String:="'新モジュール2"
''API + パブリック宣言行数
MsgBox .CountOfDeclarationLines
''コード行数
MsgBox .CountOfLines
''行あたりコード追加
.InsertLines 7, "'コメント10行目"
''指定行のコード本体
MsgBox .Lines(StartLine:=10, Count:=2)
''モジュールあたりコード本体行数
MsgBox .ProcBodyLine(ProcName:="東山1", ProcKind:=vbext_pk_Proc)
''モジュールあたりコード行数
MsgBox .ProcCountLines(ProcName:="東山1", ProcKind:=vbext_pk_Proc)
''指定モジュール開始行数
MsgBox .ProcStartLine("東山1", vbext_pk_Proc)
'指定行数コード置換
.ReplaceLine Line:=6, String:="'6行目交換"
'End With
'''タイプ
'MsgBox Application.VBE.VBProjects(2).VBComponents("Module2").Type
'└ 1=標準モジュール, 2=クラス, 3=フォーム, 11=ActiveX, 100=ドキュメントモジュール
'''新モジュール追加
'With Application.VBE.VBProjects(2)
'
.VBComponents.Add 3
'1=標準, 2=クラス, 3=フォーム
'
.VBComponents(.VBComponents.Count).Name = "新モジュール"
'
With .VBComponents(.VBComponents.Count)
'End With
'''フォーム作成, リネーム, コントロール追加
'.VBComponents.Add 3
'1=標準, 2=クラス, 3=フォーム
'.VBComponents(.VBComponents.Count).Name = "新モジュール"
- 52 -
'With .VBComponents(.VBComponents.Count)
VBA系
2016/7/30
'
'コントロール追加
'
With .Designer.Controls.Add("Forms.CommandButton.1", "CommandButton1", True)
'
.Left = 10
'
.Top = 20
'
.Width = 100
'
.Height = 100
モジュール削除
'
.ControlTipText = "京都"
ppMain.VBProject.VBComponents.Remove c
'
End With
'
'
'フォームコード追加
'
.CodeModule.AddFromString "'コメント"
'End With
Function Test_Conf1()
Dim i As Long
Dim v As Variant
With Application.VBE.VBProjects(2)
'フォーム作成, リネーム
.VBComponents.Add 3
'1=標準, 2=クラス, 3=フォーム
.VBComponents(.VBComponents.Count).Name = "新モジュール"
With .VBComponents(.VBComponents.Count)
'コントロール追加
With .Designer.Controls.Add("Forms.CommandButton.1", "CommandButton1", True)
.Left = 10
.Top = 20
.Width = 100
.Height = 100
.ControlTipText = "京都"
End With
'フォームコード追加
.CodeModule.AddFromString "'コメント"
End With
End With
MsgBox "Fnish!", 64
End Function
- 53 -
VBA系
2016/7/30
コントロール、プログレス
MSComctlLib.ProgCtrl.2
Set Ctl = UserForm1.Controls.Add("MSComctlLib.ProgCtrl.2", "Btn1", True)
水平線
イコール, チルダ, マイナス（ハイフン）, アンダーバー
ピボット, カラムF, pvfアイテム, 最大最小
Set pv = ActiveSheet.PivotTables(1)
For Each pvf In pv.ColumnFields
For Each pvi In pvf.PivotItems
Debug.Print "pvf = " & pvf.Name
Debug.Print vbTab & "└ pvi = " & pvi.Name
Debug.Print WorksheetFunction.Max(pvi.DataRange)
Next pvi
特定フィールドデータ範囲 = pvi.DataRange
Next pvf
エクセルオープン時
Private Sub Auto_Open()
正規表現
Set RE = CreateObject("VBScript.RegExp")
Microsoft VBScript Regular Expressions 5.5
プロパティ
Pattern
正規表現文字列
IgnoreCase
Trueで大文字小文字を非区分, 初期値=False
Global
Trueで全てのマッチ部分の検索・置換, 初期値=False
Multiline
Trueで各行の先頭や末尾で"^", "$"がマッチ, 初期値=False
Test
引数として文字列、正規表現マッチでTrue, 不一致でFalse
Replase
引数として検索文字列と置換後文字列
Excute
条件を指定した後のテキスト返し(Global時はカンマ区切り)
メソッド
- 54 -
VBA系
2016/7/30
正規表現パターン
シンボル 機能
^
文字列の先頭にマッチします。
$
文字列の末尾にマッチします。
\b
単語の境界にマッチします。
\B
単語の境界以外にマッチします。
\n
改行にマッチします。
\f
フォームフィード（改ページ）にマッチします。
\r
キャリッジリターン（行頭復帰）にマッチします。
\t
水平タブにマッチします。
\v
垂直タブにマッチします。
8進数（シフトJIS） xxx によって表現される文字にマッチします。"\101" は "A" に
マッチします。ただし、ASCII文字以外の文字（半角カタカナ、全角文字等）には使え
ません。
16進数（シフトJIS） dd によって表現される文字にマッチします。"\x41" は "A" に
マッチします。ただし、ASCII文字以外の文字（半角カタカナ、全角文字等）には使え
ません。
Unicode（UTF-16） xxxx によって表現される文字にマッチします。全角文字にも使え
ます。必ず xxxx の部分は4桁にしてください。"\u0041" は "A" にマッチします。
"\u3042" は "あ" にマッチします。
\xxx
\xdd
\uxxxx
[]
"[ ]" 内に含まれている文字にマッチします。"-"による範囲指定も使えます。全角
文字にも対応しています。
[^ ]
"[^ ]" 内に含まれている文字以外にマッチします。"-"による範囲指定も使えます。
全角文字にも対応しています。
\w
単語に使用される文字にマッチします。[a-zA-Z_0-9]と同じ意味です。
\W
単語に使用される文字以外の文字にマッチします。[^a-zA-Z_0-9]と同じ意味です。
.
\n 以外の文字にマッチします。全角文字にもマッチします。
\d
数字にマッチします。[0-9]と同じ意味です。
\D
数字以外の文字にマッチします。[^0-9]と同じ意味です。
\s
スペース文字にマッチします。[ \t\r\n\v\f]と同じ意味です。
\S
スペース文字以外の文字にマッチします。[^ \t\r\n\v\f]と同じ意味です。
{x}
直前の文字のx回にマッチします。
{x,}
直前の文字のx回以上にマッチします。
{x,y}
直前の文字のx回以上、y回以下にマッチします。
?
直前の文字の0または1回にマッチします。{0,1}と同じ意味です。
*
直前の文字の0回以上にマッチします。{0,}と同じ意味です。
+
直前の文字の1回以上にマッチします。{1,}と同じ意味です。
()
複数の文字をグループ化します。ネストすることができます。
|
複数の文字列を1つの正規表現にまとめ、そのうちのいずれかにマッチします。
メタ文字とエスケープ時メタ文字一覧
^　$　?　*　+　.　|　{　}　\　[　]　(　)
\^　\$　\?　\*　\+　\.　\|
\{　\}　\\　\[　\]　\(　\)
- 55 -
VBA系
2016/7/30
正規表現例, Execute
Const strConst As String = "京都az吉祥院nne."
'参照設定: Microsoft VBScript Regular Expressions 5.5
Dim Re As New VBScript_RegExp_55.RegExp
⇒ CreateObject("VBScript.RegExp")
Dim objMatches As IMatchCollection2
Dim i As Long
プロパティ3つは既存False
Re.Pattern = "[a-zA-Z]+"
パターン
Re.Global = True
Ture=全体に対し, False=で最初の1件
Re.MultiLine = True
Ture=改行ごとに対し, False=改行無視
Re.IgnoreCase = True
True=大文字小文字度外視
Set objMatches = Re.Execute(strConst)
objMatchesに結果, 配列ではない
For i = 0 To objMatches.Count - 1
MsgBox objMatches.Item(i).Value
戻り値=az, nneの2つ
Next i
正規表現例, Replace
Dim Re As New VBScript_RegExp_55.RegExp
Dim objMatches As Object
Dim strRet As String
Re.Pattern = "[^0-9]+"
Re.Global = True
Re.MultiLine = True
Re.IgnoreCase = True
strRet = Re.Replace("京都2010年8月", vbNullString)
戻り値= "20108"
MsgBox strRet
正規表現, Test
Re.Pattern = "[6-8]"
MsgBox Re.Test("京都市2015年8月")
戻り値=理論値
OLEDB.Connections
strTmp = "Select * From emp Where deptno = 10"
接続の説明書き = MsgBox ThisWorkbook.Connections(1).Description
ThisWorkbook.Connections(i).OLEDBConnection.CommandType = xlCmdSql
接続タイプ
.CommandType = xlCmdSql
コマンドテキスト
.CommandText = strTmp
再接続
.Reconnect
ソースファイル
.SourceDataFile
接続されているか
.IsConnected
- 56 -
VBA系
2016/7/30
Ex OLEObject
'
objOLE.Verb xlVerbPrimary
objOLE.Verb
'音声OLEなどの開始
'編集モードに
'編集モードエクセルセット
Set xlBK = objOLE.Parent.Parent
'エクセルブック
'編集として開かれたブックを取得
Set xlBK = xlBK.Parent.Workbooks(xlBK.Parent.Workbooks.Count)
'処理サンプル
xlBK.Sheets("Sheet2").Range("A1").Value = Now()
xlBK.Close False
IEドロップダウン (Select)
└ ①Valueから値入力 or ②Selected = Trueから
①Valueから変更
IE.Document.getElementsByName("y")(0).Value = 2014
②Selectedから
IE.Document.getElementsByTagName("Option")(2).Selected = True
└ Optionタグが上から何番目にあるか判断してSelected
⇒ (SelectedIndexを使用), コンマ文字などは下記のようにALL後へパーレン
IE.Document.all("JobListList:dgdSearchResultList:_ctl1:_ctl5").selectedIndex = 3
IE, Select内Optionテキスト取得
lngIndex = IE.Document.getElementById("m").options.selectedIndex
MsgBox IE.Document.getElementById("m").options(lngIndex).Text
mから for each 可
IEファイアーイベント
c.FireEvent("OnChange")
IEファイアーイベントをJava script起動で代替
IE.Document.parentWindow.execScript strFuncVar
strFuncVar' は java script 中のファンクション名と変数
function ChangePic(myPicURL, lngHeight, strComment){
IEラジオボタン
①Checked = True, or ②クリックから
①
IE.Document.getElementById("tsFir").Checked = True
②
IE.Document.getElementById("tsArr").Click
散布図 近似曲線数式
Debug.Print Se.Trendlines(1).DataLabel.Text
(ex) y = 12.167x - 24355
Excel 改行置換, 手動操作時
Ctrl + H ⇒ Ctrl + J
Ctrl + Jで空白が入力されているように見れるが改行コード
- 57 -
VBA系
2016/7/30
IE,
タグネームのn番目
IE.Document.getElementsByTagName("Option")(n).Selected = True
IDは単数 GetElementByID("") ⇒ IDはユニーク
Nameは複数かつn番目指定 GetElementsByName("Li")(1).InnerText
TagNameも同様にn番目指定
Word使用, 単語区切り
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim wdWord As Object
Dim vntSpt As Variant
Set wdDoc = wdApp.Documents.Add
wdApp.Visible = True
wdDoc.Range.Text = _
"本日の京都市南区吉祥院" & vbNewLine & "の天気予報は雪です。"
'単語単位で区切り
For Each wdWord In wdDoc.Words
MsgBox wdWord
Next
'改行区切りで格納(vbNewline, vbLF不可 ⇒ vbCR or Chr(13)で
vntSpt = Split(wdDoc.Range.Text, vbCr)
MsgBox vntSpt(0)
wdApp.Quit False
Set wdApp = Nothing
Set wdDoc = Nothing
IE各種バー表示
IE.StatusBar = True
ツールバーが一番親, ツールバー非表示では
IE.MenuBar = True
メニューバーやアドレスバーも非表示
IE.AddressBar = True
IE.Toolbar = True
IE.Toolbar = False
IE.navigate "http://transit.loco.yahoo.co.jp/"
IE.navigate2 "http://weather.yahoo.co.jp/weather/", 2048
別タグへ
IE.Toolbar = True
- 58 -
VBA系
2016/7/30
SendKey
SendKeys "%(yy)"
%y ⇒ %y
Sendkeys "%yy"
%y ⇒ y
既存エクスプローラー or IE位置サイズ調整
Dim objSL As New Shell32.Shell
Dim c As Object
フォルダ ⇒ IShellFolderViewDual3
For Each c In objSL.Windows
file:///D:/Work
MsgBox TypeName(c.Document) & vbNewLine & c.LocationURL
IE時 ⇒ HTMLDocument
c.Left = 100
Next c
http://yahoo.co.jp
コレクション
Dim Col As New Collection
'コレクションは1スタート not zero
Col.Add "京都府", "都道府県"
Col.Add "京都市", "市"
Col.Add "南区", "区"
Col.Add "吉祥院", "町1"
Col.Add "這登西町", "町2"
MsgBox Col("区") & vbNewLine & Col(4)
Col.Remove 1
MsgBox Col("区") & vbNewLine & Col(4)
MsgBox Col.Count
Rsのようにフィールド名でもインデックスでも値取得可能(上書き)
インデックスは1スタート not zero
コレクション
Dim cl_Sh As New Collection
cl_Sh.Add ActiveSheet, "ShMain"
配列可能
要素のデータ型問わず
cl_Sh("ShMain").Tab.Color = vbGreen
For Each v In cl_Sh
MsgBox v.Name
Next v
IEタグ操作
IE.Document.ALL.y(0).InnerText
Name=y, n-1番目(インデックスゼロスタート)
- 59 -
VBA系
2016/7/30
IEポップアップ
IE9から GetLastActivePopupは使用不可のためFindWindowを使用
FindWindow("#32770", "Web ページからのメッセージ")
データ型、変数型
TypeNameで取得可能
TypeName(CreateObject("Shell.Application").Windows) ⇒ IShellWindows
IE_ALL各種取得方法
MsgBox objIE.document.all(0).outerHTML
MsgBox objIE.document.all.Item(0).outerHTML
MsgBox objIE.document.all.tags("html")(0).outerHTML
MsgBox objIE.document.getElementsByTagName("html")(0).outerHTML
Like演算子, 以外判定
イクスクラメーション【!】使用, ブラケットで囲む
この場合、ブラケット内文字列は1つの文字列 (like word) として扱われる
Like "[京都]*", Like "[!京都]*"
IE, 子に対して検索
For Each cc In c.Children
MsgBox cc.innerText
Next cc
子の特定タグに対し ⇒ For Each cc In c.getElementsByTagName("Option")
ダイレクトに ⇒ MsgBox c.getElementsByTagName("Option")(0).innerText
IE一般用語
パワポノート
ppSp.Parent.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = "京都"
エクセルブック範囲（名前範囲）
Set rngFrom = xlBK.Parent.Range("pvRng")
Set rngFrom = Application.Range("Book1.xlsm!pvRng")
- 60 -
VBA系
2016/7/30
IE, ウィンドウスクロール
IE.Document.parentWindow.execScript "window.scrollTo(100, 100);"
絶対座標
IE.Document.parentWindow.execScript "window.scrollBy(100, 100);"
相対座標
第二引数が縦位置
【特定IDへ】
location.hash ="TestID2";
(左記をそのまま execScript の引数へ)
window.scrollBy(0, -10);
絶対パス取得
MsgBox FSO.GetAbsolutePathName("..\")
VBAからも可能
var FSO = new ActiveXObject("Scripting.FileSystemObject");
java script
strPath = FSO.GetAbsolutePathName( './' );
alert( strPath );
Ac以外のユーザーフォーム、コントロール削除
Set Designer = xlBK.VBProject.VBComponents("UserForm1").Designer
Set Ctrl = Designer.Controls.Add("Forms.CommandButton.1", "Btn1", True)
Designer.Controls.Remove "Btn1"
hoge, piyo, fuga,
foo, bar, baz
Alice and Bob
23, 42
AliceがBobに情報を送る
Shell.Appli
デスクトップ表示
Shel.ToggleDesktop
フォルダオープン
Shel.Open "d:\db"
Shell32.Shell
fso getExtensionName ⇒ 実在しないファイルでも可
("D:aaaaa.cccsv" ⇒ "cccsv")
グループ化のバイトケース
acグループ化
全角半角大文字小文字すべて同じとみなす
xlピボット
大文字小文字は同じとみなす。全角半角は別。
ADO_SQL
acグループ化と同じで全て同じとみなす。
scripting.Dictionary
全角半角大文字小文字すべて区別する。
acインポートエクスポート定義
("保存済みのインポート操作" の方)
Dim c As ImportExportSpecification
Set c = CurrentProject.ImportExportSpecifications("imDef1")
Debug.Print cc.XML
- 61 -
VBA系
2016/7/30
html テーブル内の隣行列
var ele= document.getElementById("cc")
alert(ele.parentElement.innerText);
alert(cc.innerText);
alert(cc.parentElement.children[1].innerText + '\n └ 右列');
alert(cc.parentElement.parentElement.children[1].children[0].innerText + '\n └ 下行');
xlセルエラー
Rng.Errors(xlNumberAsText).Ignore = True
パスワード付acへ接続
Set db = DBEngine.Workspaces(0).OpenDatabase(strmdb, False, False, ";pwd=パスワード")
ワードへペースト
Set WordDoc = ObjWord.Application.Documents.Add
WordDoc.Paragraphs(1).Range.Paste
花束文字
🎉
ChrW(-10180) & ChrW(-8311)
xlコンボ
候補文字列を表示しない ⇒ MatchEntry = 2-fmMatchEntryNone
adoからのパラメーターacクエリの実行
cmd.ActiveConnection = cn
cmd.CommandText = "q1"
'単純なクエリ名
cmd.CommandType = adCmdTable
cmd.Parameters.Refresh
cmd.Parameters(0) = "oosaka"
'インデックス番号のみ
Set rs = cmd.Execute
- 62 -
CommandBar
VBA系
2016/7/30
Static n As Long
Dim objCB As CommandBar
Dim objCtl As CommandBarButton
Dim strName As String
n=n+1
strName = "京都" & n
Set objCB = Application.CommandBars.Add(Name:=strName _
, Position:=msoBarTop, MenuBar:=False, Temporary:=True)
Set objCtl = objCB.Controls.Add(Type:=msoControlButton)
Application.CommandBars(strName).Visible = True
With objCtl
.Caption = "SampleCaption" & n
.Style = msoButtonCaption
.Style = msoButtonIconAndCaption
.FaceId = 483
.BeginGroup = True
.OnAction = "SampleOnAction"
End With
With Application.CommandBars(strName)
.Visible = True
.Position = msoBarTop
End With
IE画像非表示、処理速度向上
インターネットオプション ⇒ 詳細設定 ⇒ (下の方) ☑ 画像を表示する
Acから他のAc操作
Dim wsp As Workspace
Dim db As Database
Dim rs As DAO.Recordset
Set wsp = DBEngine.CreateWorkspace("", "Admin", "")
Set db = wsp.OpenDatabase("D:\DB\DB.accdb")
wsp.BeginTrans
Set rs = db.OpenRecordset("select * from t1")
- 63 -
VBA系
2016/7/30
ピボット内範囲詳細
※特定範囲選択
MsgBox pvf.DataRange(1, 1) & vbNewLine & pvf.DataRange(2, 2) & vbNewLine & pvf.DataRange(3, 3)
※特定複数範囲選択
MsgBox WorksheetFunction.Sum(pvf.DataRange(1, 3), pvf.DataRange(2, 4))
※連続範囲選択
MsgBox WorksheetFunction.Sum(Range(pvf.DataRange(1, 3), pvf.DataRange(2, 4)))
※ピボットアイテム範囲
MsgBox WorksheetFunction.Sum(pvf.PivotItems("東京").DataRange)
※ピボット全体ソース範囲
MsgBox Application.ConvertFormula(pv.SourceData, xlR1C1, xlA1)
データ範囲行列数取得
pvf.DataRange.Rows.Count (col同様)
ピボットアイテム範囲セル
pvf.DataRange.Address (最左1列のみ)
レコードセット保存から
rs.Open CurrentProject.Path & "\rs", , adOpenKeyset, adLockOptimistic
MsgBox rs(1)
rs.Update "Num", 22
rs.Save
rs.Close
Cn接続しない複数DBをJon結合サンプル
Select L.Str, R.Str2, L.Int From
(Select Str, StrInt, Int From [Sheet1$] As L In 'D:\DB\Book1.xlsm' 'Excel 8.0;Hdr=Yes') As L
Left Join
(Select Str, Str2 From [Sheet2$] As R In 'D:\DB\Book3.xlsm' 'Excel 8.0;Hdr=Yes') As R
On L.Str = R.Str
○Ac内部と外部DBでのJoin⇒クエリ, ADO共に可確認
○Ex内部と外部DBでのJoin⇒ADO可確認済
○AcからExへADOCn接続中は、該当エクセル自体をRs取得不可
- 64 -
VBA系
2016/7/30
xl から DAO 接続からの SQL, Format関数可
Format 関数利用可
rs.MoveLast に一度行けば rs.RecordCount 可
rs.AbsolutePosition 可
strSQL = "Select Str, Format(Int, '#,##0') As _Int_ From [Sheet1$];"
With CreateObject("DAO.DBEngine.120").Workspaces(0)
Set DB = .OpenDatabase(strPath, False, True, "Excel 8.0;Hdr=Yes")
Set rs = DB.OpenRecordset(strSQL, dbOpenSnapshot)
End With
OpenDatabase( name, options, readonly, connect) = (, 排斥, , excel 8.0;hdr)
ex リストボックス
List に2次配列可能
.Column(Col, Row) で値セット可能
特定IE最前面
SetForegroundWindow ie.hWnd
エクセル, ウィンドウ, アプリ系
xlApp.CommandBars.ExecuteMso "MinimizeRibbon"
リボン
xlApp.DisplayFormulaBar = False
数式バー
xlApp.DisplayFullScreen = False
フルスクリーン
xlApp.DisplayScrollBars = False 'シート部分含む
スクロールバー
xlApp.DisplayStatusBar = False
ステータスバー
xlApp.Windows(1).DisplayGridlines = False
グリッドライン
xlApp.Windows(1).DisplayHeadings = False
ヘッドライン
xlApp.Windows(1).DisplayVerticalScrollBar = False
縦スクロールバー
xlApp.Windows(1).DisplayHorizontalScrollBar = False
横スクロールバー
xlApp.Windows(1).DisplayZeros = False
ゼロ表示
xlap.Windows(1).DisplayWorkbookTabs=False
シートバー
xlApp.CommandBars.ExecuteMso "MinimizeRibbon"
"MinimizeRibbon" 中は大文字と小文字区分
実行されるたびに 最大化と最小化入替え
リボンが最少化されているかの確認
Application.CommandBars.GetPressedMso("MinimizeRibbon")
上記Trueが最小化、Falseは逆
- 65 -
VBA系
2016/7/30
https://msdn.microsoft.com/ja-jp/library/office/ff823068.aspx?f=255&MSPPError=-2147217396
Webページとして保存
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange _
ソースタイプ, (下記参考)
, Filename:=strFile _
ファイルフルネーム(D:\file.mht)
, Sheet:="Sheet1" _
SourceTypeがシート時に指定
, Source:="$A$1:$F$37" _
SourceTypeがピボットやセル範囲時に指定
, HtmlType:=xlHtmlStatic _
(xlHtmlStatic)以外廃止なので通常省略に)
, DivID:="" _
(通常省略)
, Title:="京都")
SouceTyepセル範囲指定でトップ表示
.Publish (True)
.AutoRepublish = False
SouceType:=Book ⇒
End With
SourceType
xlSourceAutoFilter
3 オートフィルターの範囲
xlSourceChart
5 グラフ
xlSourcePivotTable
6 ピボットテーブル レポート
xlSourcePrintArea
2 印刷用に選択したセル範囲
xlSourceQuery
7 クエリ テーブル (外部データ範囲)
xlSourceRange
4 セル範囲
xlSourceSheet
1 ワークシート全体
xlSourceWorkbook
0 ブック
※ピボットやセル範囲時はピボット名や範囲名を 'Source'へ指定
SQL日付(ado)
select L.prefecCode, R.prefecCode, R.Prefecture, L.sDate, L.Num, L.Str from
(select * from [data$] in 'D:\data.xlsm' 'excel 8.0;hdr=yes;') as L
left join
(select * from [prefecture.csv] in 'D:\' 'text;hdr=yes;') as R
on L.prefecCode = R.prefecCode
where sDate in (#2015/01/01#, #2015/1/2#)
シングル不可
order by L.prefecCode asc;
ado, レコード操作
rs.Find _
ファインドはメソッド
Criteria:="Prefecture = '京都府'" _
, SkipRecords:=0 _
, SearchDirection:=adSearchForward _
, Start:=0
- 66 -
VBA系
2016/7/30
ウィンドウハドル
ac
MsgBox hWndAccessApp
pp(2010, 2013)
MsgBox FindWindow("PPTFrameClass", ppMain.Application.Caption)
ex
MsgBox FindWindow("XlMain", vbNullString)
エクセル散布図, ポイント
Set ct = ActiveSheet.ChartObjects(1).Chart
Set se = ct.SeriesCollection
For Each s In ct.SeriesCollection
For Each p In s.Points
Debug.Print p.Name = "S1P2"
シリーズ1のポイント2
エクセルグラフ, ソース範囲最大値など
MsgBox WorksheetFunction.Max(se.Item(2).Values)
ADO SQL から StrConv可能
1
大文字
8
全角⇒半角
2
小文字
16
ひらがな⇒カナ
3
先頭を大文字
32
カナ⇒ひらがな
4
半角⇒全角
IE
ToolBar=AddressBar
↓はステータスバー
- 67 -
VBA系
2016/7/30
Ac列幅
CurrentDb.QueryDefs("Q_Test").Fields("Str").Properties("ColumnWidth").Value=5000
└ クエリに適用すれば、該当クエリをRowSourceとするサブフォームにも有効
リボン非表示 (not 最小化)
DoCmd.ShowToolbar "Ribbon", acToolbarNo
DoCmd.ShowToolbar "Ribbon", acToolbarYes
xlApp.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",False)"
xlApp.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",True)"
最小化確認 = xlApp.CommandBars.GetPressedMso("MinimizeRibbon")
スプリット分解中文字列配列群
Const str As String = "aa bb cc dd"
For Each c In Split(str)
Split 指定無しでスペース区切り
MsgBox c
Next
MsgBox Split(str)(0)
undo
単発で使用も可能
App.CommandBars.ExecuteMsoは ac, xl 共に有り
Application.CommandBars.ExecuteMso "Undo"
Application.CommandBars.ExecuteMso "Redo"
acフォーム下部, レコードセレクタ及び移動ボタン
Having
HAVING句では、SELECT句で指定していないフィールドを条件に使用することもできます
Havingは集計後結果の条件
単純右クリックショートカット
Shift + F10
VBEコマンドバー
VBEツールバーを右クリック ⇒ ユーザー設定 ⇒ ツールバー ⇒ ショートカットメニュー
ユーザー設定ダイアログ中のコマンドタブからショートカットメニューをドラッグ
- 68 -
acフォームフォーマット
VBA系
2016/7/30
分割フォーム
acボタンの画像表題
- 69 -
VBA系
2016/7/30
- 70 -
VBA系
2016/7/30
ツリービューコントロール
Dim xlSh As Excel.Worksheet
Dim TrV As TreeView
Dim Nodes1 As Node
'ツリービュー定義(oleObjects.Object)
Set xlSh = ActiveSheet
Set TrV = xlSh.OLEObjects("TreeView31").Object
'イメージリストと関係
TrV.ImageList = xlSh.OLEObjects("ImageList31").Object
'外見
TrV.Appearance = cc3D
TrV.Appearance = ccFlat
'枠線
TrV.BorderStyle = ccFixedSingle
TrV.BorderStyle = ccNone
'枠線スタイル
TrV.LineStyle = tvwTreeLines
TrV.LineStyle = tvwRootLines
'チェックボックスの有無
TrV.CheckBoxes = False
TrV.CheckBoxes = True
TrV.FullRowSelect = False
TrV.FullRowSelect = True
'全体スタイル
TrV.Style = tvwPictureText
TrV.Style = tvwPlusMinusText
TrV.Style = tvwPlusPictureText
TrV.Style = tvwTextOnly
TrV.Style = tvwTreelinesPictureText
TrV.Style = tvwTreelinesPlusMinusPictureText
TrV.Style = tvwTreelinesPlusMinusText
'●Main●
TrV.Style = tvwTreelinesText
- 71 -
TrV.Style = tvwTreelinesPlusMinusPictureText
VBA系
2016/7/30
'ノードあたり設定
TrV.Nodes(1).BackColor = RGB(255, 255, 200)
TrV.Nodes(1).Bold = True
TrV.Nodes(1).Checked = True
TrV.Nodes(1).ForeColor = vbGreen
TrV.Nodes(1).Image = "a"
TrV.Nodes(2).Selected = True
TrV.Nodes(1).Text = TrV.Nodes(1).Text & "★"
'ノード登録
TrV.Nodes.Clear
TrV.Nodes.Add Key:="key1", Text:="Parent1"
TrV.Nodes.Add Key:="key2", Text:="Parent2"
TrV.Nodes.Add Key:="key3", Text:="Parent3"
'定数tvwChild=4
TrV.Nodes.Add Relative:="key1", Relationship:=tvwChild _
, Key:="key1-1", Text:="Parent1-A"
TrV.Nodes.Add Relative:="key1", Relationship:=tvwChild _
, Key:="key1-2", Text:="Parent1-B"
TrV.Nodes.Add Relative:="key3", Relationship:=tvwChild _
, Key:="key3-1", Text:="Parent3-A"
TrV.Nodes.Add Relative:="key3", Relationship:=tvwChild _
, Key:="key3-2", Text:="Parent3-B", Image:="a"
TrV.Nodes.Add Relative:="key3-1", Relationship:=tvwChild _
, Key:="key3-1-1", Text:="Parent3-A-a", Image:="a", SelectedImage:="b"
'ノード削除
TrV.Nodes.Remove "key2"
'ノード選択
TrV.Nodes("key3").Expanded = False
TrV.Nodes("key3-1-1").Selected = True
TrV.Nodes("key3-1-1").Selected = False
- 72 -
VBA系
2016/7/30
'ノード変数セットとプラスマイナス拡張
Set Nodes1 = TrV.Nodes("key3")
Nodes1.Expanded = False
Nodes1.Expanded = True
Set TrV = Nothing: Set Nodes1 = Nothing
(参考)参照設定
Microsoft ActiveX Data Objects 2.8 Library
Microsoft ADO Ext. 2.8 for DDL and Security
Microsoft Excel 15.0 Object Library
Microsoft HTML Object LIbrary
Microsoft Internet Controls
Microsoft Outlook 15.0 Object Library
Microsoft PowerPoint 15.0 Object Library
Microsoft Scripting Runtime
Microsoft Shell Controls And Automation
Microsoft VBScript Regular Expressions 5.5
Microsoft Word 15.0 Object Library
Microsoft Script Host Object Model
Microsoft Office 15.0 Object Library
Microsoft Visual Basic for Applications Extensitbliry
UIAutomationClient
ac現在実行中のフォーム参照
Dim obj As Form
Set obj = Application.CodeContextObject
コード実行元のフォームやレポート
acデザインで非表示コントロールの表示
forms(0).chktest1.inselection=true
acフォームオープン確認
lngRet = SysCmd(acSysCmdGetObjectState, acForm, "F_SetPpPosition")
strRet = IIf(lngRet = 1, "Opened", "Closed")
MsgBox strRet
strRet = IIf(CurrentProject.AllForms("F_SetPpPosition").IsLoaded _
, "Opened", "Closed")
MsgBox strRet
CurrentProject.AllForms("f1").IsLoaded
CurrentData.AllTables("t1").IsLoaded
- 73 -
VBA系
2016/7/30
acセクション
MsgBox acForm.Section(i).Controls.Count
acDetail, acHeader, acFooter, acPageHeader, acPageFooter
acフォームやコントロール作成
Dim acForm As Access.Form
acBoundObjectFrame
Dim acText As Access.TextBox
acCheckBox
チェック ボックス
acComboBox
コンボ ボックス
'フォーム作成
acCommandButton
Set acForm = CreateForm()
acCustomControl
'レコードソース
連結オブジェクト フレーム
コマンド ボタン
ActiveX コントロール
acImage
イメージ
acLabel
ラベル
acLine
直線コントロール
acForm.RecordSource = "T1"
'キャプション
acListBox
リスト ボックス
acForm.Caption = "Cap"
acObjectFrame
非連結オブジェクト フレーム
acOptionButton
オプション ボタン
'コントロール(テキストボックス)作成
acOptionGroup
オプション グループ
Set acText = CreateControl( _
acPage Page
オブジェクト
acPageBreak
改ページ コントロール
FormName:=acForm.Name _
, ControlType:=acTextBox _
, Section:=acDetail _
, Parent:="" _
, ColumnName:="Str" _
, Left:=100, Top:=100, Width:=1500, Height:=500)
'フォームオープン
acRectangle
四角形
DoCmd.OpenForm acForm.Name
acSubｆorm
サブフォーム
acTabCtl
acTextBox
'終了
acToggleButton
タブ コントロール
テキスト ボックス
トグル ボタン
Set acText = Nothing: Set acForm = Nothing
acエクスポート
Docmd.OutputTo ⇒ 書式付き
Docmd.TransferSpreadSheet ⇒ 値のみ
xlピボット範囲セル
MsgBox pv.DataBodyRange.Address
pv.DataBodyRange = ピボット中の Data Fields セル範囲
pv.SourceData = ピボットソースデータのセル範囲
MsgBox Application.ConvertFormula(pv.SourceData, xlR1C1, xlA1)
- 74 -
VBA系
2016/7/30
ac日付ピッカー (テキストボックス)
Set fm = Forms("F_TempTest")
Set txt = fm.Controls("txt1")
MsgBox txt.ShowDatePicker
txt.ShowDatePicker = 0 '0=なし, 1=日付
acモジュールプロシージャオープン
DoCmd.OpenModule "M_MyFunc_xl", "retChartType"
モジュール名, プロシージャー名
transferSpreadSheetは対象xlは開いていてはいけない
acウィンドウサイズ
DoCmd.Maximize
Maximize ⇔ Minimize
DoCmd.RunCommand acCmdAppMaximize
xl常に最前面
Option Explicit
Public Declare Function SetWindowPos Lib "user32" _
(ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long _
, ByVal cy As Long, ByVal fuFlags As Long) As Long
Function wndPos_Test()
Application.Wait DateAdd("s", 2, Now)
'アプリを一度最前面に(SetWindowPosは最前面であることが条件)
Application.ScreenUpdating = False
Application.WindowState = xlMaximized
Application.WindowState = xlNormal
Application.ScreenUpdating = True
'SetWindowPosからウィンドウポジションセット
'第二引数は -1=常に最前面, -2=ノーマル
'第三引数以後4つは Left, Top, Width, Height
SetWindowPos Application.hWnd, -1, 200, 200, 800, 600, 0
'
SetWindowPos Application.hWnd, -2, 200, 200, 800, 600, 0
'終了
MsgBox Application.hWnd
End Function
- 75 -
VBA系
2016/7/30
ac上記のacVer
標準モジュールへ
Public Declare Function GetSystemMetrics Lib "user32.dll" ( _
ByVal nIndex As Long) As Long
Public Declare Function SetWindowPos Lib "user32" _
(ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal fuFlags As Long) As Long
'フォームの開くとき
Private Sub Form_Open(Cancel As Integer)
'最大表示で常に最前面設定
SetWindowPos Me.hWnd, -1, 0, 0, GetSystemMetrics(0), GetSystemMetrics(1), 0
SetWindowPos Me.hWnd, -1, 100, 100, 800, 600, 0
End Sub
'クリック時
Private Sub コマンド0_Click()
DoCmd.SetWarnings False
DoCmd.Close acForm, Me.Name
DoCmd.SetWarnings True
End Sub
Private Sub コマンド1_Click()
'常に最前面設定解除
SetWindowPos Me.hWnd, -2, 100, 100, 800, 600, 0
End Sub
ieを別タブで開く
ie.navigate "http://weather.yahoo.co.jp/weather/"
ie.navigate2 "yahoo.co.jp", 2048
Navigate2 の第二引数に "2048"
- 76 -
VBA系
2016/7/30
acフォーム自体設定
Sub BorderStyleSample()
Dim myForm As Form
'最小化したフォームを作成
Set myForm = CreateForm()
With myForm
'レコードセレクタ
.RecordSelectors = True
'移動ボタン
.NavigationButtons = True
'区切り線
.DividingLines = True
'境界線スタイル：0=なし, 1=細線, 2=サイズ調整可, 3=ダイアログ
'1=ctrlメニューなし, 最大最少なし, 閉じるなし
'1 and 2=上記3つすべて有り
'3=上記3つの内最大最少のみ無し
'サイズ変更は 2 のみ可能
.BorderStyle = 1
'コントロールボックス
.ControlBox = False
'作業ウィンドウ固定
.Modal = True
'ポップアップ
.PopUp = True
'スクロールバー: 0=なし, 1=水平のみ, 2=垂直のみ, 3=Both
.ScrollBars = 3
'標題設定
.Caption = "Cap"
End With
'フォームビューでフォームを開く
DoCmd.OpenForm myForm.Name
Forms(0).Move 100, 100, 3000, 3000
End Sub
VBScript 自ファイルパス
WScript.ScriptFullName
dim fso
set fso = createObject("Scripting.FileSystemObject")
msgbox fso.getParentFolderName(WScript.ScriptFullName)
- 77 -
xl クラスモジュールからのシートイベント
VBA系
2016/7/30
クラスモジュールへ Public WithEvents shTarget As Excel.Worksheet
xlグラフ範囲の動的変更
①チャートソース範囲に名前付与（シリーズごとに、全体を一括では×）
②シリーズ関数に上記名前を代入 ⇒ 後はピボットと同じく動的変更
◆範囲名はブック名を付与する
○ Book1.xlsm!aaa
× aaa
xl他のブックの範囲名取得
(ブック名) ! (範囲名)
MsgBox Range(Book1.xlsm!aaa).Address
vba で複数のレコードセットを含む場合のrs移動
Set rs = rs.NextRecordset()
adoからのパラメーターacクエリの実行
cmd.ActiveConnection = cn
cmd.CommandText = "q1"
'単純なクエリ名
cmd.CommandType = adCmdTable
cmd.Parameters.Refresh
cmd.Parameters(0) = "oosaka"
'インデックス番号のみ
Set rs = cmd.Execute
- 78 -
VBA系
2016/7/30
- 79 -
VBA系
2016/7/30
- 80 -
VBA系
2016/7/30
- 81 -
VBA系
2016/7/30
- 82 -
VBA系
2016/7/30
- 83 -
VBA系
2016/7/30
- 84 -
VBA系
2016/7/30
- 85 -
VBA系
2016/7/30
- 86 -
VBA系
2016/7/30
- 87 -
VBA系
2016/7/30
- 88 -
VBA系
2016/7/30
- 89 -
VBA系
2016/7/30
- 90 -
VBA系
2016/7/30
- 91 -
VBA系
2016/7/30
- 92 -
VBA系
2016/7/30
- 93 -
VBA系
2016/7/30
- 94 -
VBA系
2016/7/30
- 95 -
VBA系
2016/7/30
- 96 -
VBA系
2016/7/30
- 97 -
VBA系
2016/7/30
- 98 -
VBA系
2016/7/30
- 99 -
VBA系
2016/7/30
- 100 -