Excel

category

Excel: VBA覚え書き

 

項 目 コード
基本
コメント ‘*******************************************************
‘************                                                        ************
‘************                                                        ************
‘************                                                        ************
‘*******************************************************
変数の定義 Dim n As String ‘文字列
Dim n As integer ‘整数型 -32,768 ～ 32,767
Dim n As Long ‘長整数型 -2,147,483,648 ～ 2,147,483,647
Dim n As Single ‘単精度浮動小数点数型
Dim n As Double ‘倍精度浮動小数点数型
Dim n As Currency ‘通貨型
Dim n As Date ‘日付型
Dim n As Object ‘オブジェクト型
Dim n As Variant ‘バリアント型：可変長の文字列型の範囲と同じ。
Dim n As Boolean ‘ブール型：真 (True) または偽 (False)
Dim Wb As Workbook ‘ワークブック
Dim Sh As Worksheet ‘ワークシート
 カットコピーモード終了  Application.CutCopyMode = False
 アクティブにする  Workbooks(“記録.xls”).Sheets(1).Activate
 画面の更新停止  Workbooks(“記録.xls”).SaveApplication.ScreenUpdating = False ‘画面の更新停止
Application.ScreenUpdating = True ‘画面の更新再開
 ステータスバーの表示  Application.DisplayStatusBar = True ‘画面の下の方にステータスバーを表示
Application.StatusBar = “マクロを実行中．”
Application.DisplayStatusBar = False ‘画面の下の方にステータスバーを非表示
 上書き・結合・シートの削除時の警告表示の停止，再開  Application.DisplayAlerts = False
Application.DisplayAlerts = True
 エラー処理のスキップ  On Error Resume Next
Wb1.Sheets(“シート確認”).Activate ‘選択するシートが無かったら，無視して次へ
On Error GoTo 0
 取得類
 パスの取得  Dim myPath As String ‘パス名
myPath = ThisWorkbook.Path ‘このコードが入っているブックのパス名取得
 フォルダ名の取得  Dim DirN As String ‘フォルダ名用の変数
myPath = ThisWorkbook.Path ‘このコードが入っているブックのパス名取得
DirN = Dir(myPath, vbDirectory)
 ファイル名の取得（「.xls」を除いた部分)  Dim GraN2 As String
Dim n as Integer
n = InStr(1, ThisWorkbook.Name, “.”, vbTextCompare) ‘ピリオド位置の把握
GraN2 = Left(ThisWorkbook.Name, n – 1) ‘ピリオドから左側をファイル名として取得
 拡張子の取得  Dim GraN1 As String
Dim n as Integer
n = InStr(1, ThisWorkbook.Name, “.”, vbTextCompare) ‘ピリオド位置の把握
GraN1 = Mid(取得したファイル名, ピリオド位置 + 1) ‘ピリオドから右側を拡張子名として取得
 シート名の取得  Dim Buf As String ‘シート名用の変数
Buf = ActiveSheet.Name
 シート数の取得  Workbooks(“記録.xls”).Sheets.Count
 時の取得  Dim Jikan As String
Jikan = Hour(Now())
 分の取得  Dim Fun As String
Fun = Minute(Now())
 グラフ系列数の取得  Dim n As Integer
ns = ActiveChart.SeriesCollection.Count ‘グラフ系列数の取得
 セルA1から行列が空でない範囲まで選択  Range(“A1”).CurrentRegion.Select
 一度でも使用したセル全て選択  ActiveSheet.UsedRange ‘アクティブシートの一度でも使用したセル全て選択
 範囲の行数，列数を取得  Range(“B3:K34”).Rows.Count
Range(“B3:K34”).columns.Count
 アクティブセルが1つのときの行番号，列番号の取得  ActiveCell.row ‘行番号の取得
ActiveCell.Column ‘列番号の取得
 選択範囲の最初の行番号，列番号を取得  Range(“D3:F8”).row ‘選択範囲の最初の行番号を取得。この場合，3
Range(“D3:F8”).column ‘選択範囲の最初の列番号を取得。この場合，4
 選択範囲の最下行，最右列だけ選択  Range(“C3:F8”).row ‘選択範囲の最初の行番号を取得。この場合，3
Selection.Rows(Selection.Rows.Count).Select ‘選択範囲のうち，一番最下の行を選択
Selection.Rows(Selection.columns.Count).Select ‘選択範囲のうち，一番最右の列を選択
 選択範囲の最下行番号，最右列番号を取得  Range(“A3:F9”).Select
Selection.Rows(Selection.Rows.Count).Row
Selection.Rows(Selection.Rows.Count).column
 1列目で入力されている最後の行番号を取得する（下側に検索する場合）  Cells(1, 1).End(xlDown).Row
 1列目で入力されている最後の行番号を取得する（上側に検索する場合）  Cells(1048576, 1).End(xlUp).Row
 1行目で入力されている最後の列番号を取得する（右側に検索する場合）  Cells(1, 1).End(xlToRight).Column
 1行目で入力されている最後の列番号を取得する（左側に検索する場合）  Cells(16384, 1).End(xlUp).Column
 グラフ関連
 ワークシートのオブジェクトを全削除  Worksheets(1).DrawingObjects.Delete
 シート内のグラフを順に選択  Dim chrt As ChartObject
For Each chrt In ActiveSheet.ChartObjects ‘シート内のグラフを順に選択
chrt.Select
Next chrt
 グラフのフォントサイズ固定  Sub グラフのフォントサイズ固定()
On Error Resume Next
Selection.AutoScaleFont = False
On Error GoTo 0
End Sub
 グラフをGIF画像ファイルとして保存する  ActiveChart.Export Filename:=”c:\graph\test.gif”, FilterName:=”GIF”
 グラフプロパティ  ActiveChart.Placement = xlFreeFloating ‘セルに合わせて移動やサイズを変更しない
ActiveChart.Placement = xlMove ‘セルに合わせて移動するがサイズは変更しない
ActiveChart.Placement = xlMoveAndSize ‘セルに合わせて移動やサイズを変更する
ActiveChart.PrintObject = True ‘オブジェクトを印刷する
ActiveChart.Locked = True ‘ロック
 グラフの種類  グラフの種類
.Chart.ChartType = xlColumnClustered ‘縦棒グラフ
.Chart.ChartType = xlBarStacked100 ‘100%積上げ横棒グラフ
.Chart.ChartType = xlColumnClustered ‘集合縦棒グラフ
.Chart.ChartType = xlBubble ‘球グラフ
.Chart.ChartType = xlXYScatterSmoothNoMarkers
 グラフのフォントの設定  ActiveChart.ChartArea.Font.Name = “ＭＳ Ｐゴシック” ‘フォントの設定
ActiveChart.ChartArea.Font.ColorIndex = 2 ‘フォントカラー
ActiveChart.ChartArea.AutoScaleFont = False ‘フォントサイズの自動調整ストップ
ActiveChart.ChartArea.Font.Size = 9 ‘フォントサイズの設定
 グラフの追加  With ActiveSheet.ChartObjects.Add(180, 180, 250, 150) ‘シートの横位置，縦位置，グラフの横幅，縦幅
End with
 棒グラフの作成  With ActiveSheet.ChartObjects.Add(180, 180, 250, 150) ‘シートの横位置，縦位置，グラフの横幅，縦幅
.Chart.ChartType = xlColumnClustered ‘グラフの種類の設定
.Chart.SetSourceData Source:=Sheets(“単純”).Range(“A1:D4”), _’グラフ範囲の設定
PlotBy:=xlColumns ‘系列を行と列のどちらで分けるか判断.Chart.Location Where:=xlLocationAsObject, Name:=ActiveSheet.Name ‘グラフをシート上に配置End With
 グラフ系列数の取得  ActiveChart.SeriesCollection.Count ‘グラフ系列数の取得
 グラフタイトル表示とタイトル名  With ActiveChart
.HasTitle = True ‘グラフタイトルの表示
.ChartTitle.Characters.Text = “グラフタイトル” ‘グラフタイトル名の設定
.ChartTitle.Left = 20 ‘グラフタイトルの配置左側
.ChartTitle.Top = 20 ‘グラフタイトルの配置上側
End With ‘ActiveChart
 プロットエリアの設定  With ActiveChart
.PlotArea.Width = 270 ‘プロットエリアの横幅
.PlotArea.Height = 110 ‘プロットエリアの縦幅
.PlotArea.Top = 15 ‘プロットエリアからグラフエリアまでの上部余白
.PlotArea.Left = 15 ‘プロットエリアからグラフエリアまでの縦幅
.PlotArea.Border.ColorIndex = 1
.PlotArea.Interior.ColorIndex = 2
.PlotArea.Interior.PatternColorIndex = 1
.PlotArea.Interior.Pattern = xlSolid
End With ‘ActiveChart
 グラフエリアの設定  With ActiveChart
.ChartArea.Border.LineStyle = 0
.ChartArea.Interior.ColorIndex = 2
.ChartArea.Interior.PatternColorIndex = 1
.ChartArea.Interior.Pattern = xlSolid
End With ‘ActiveChart
 凡例の設定  ActiveChart.HasLegend = True ‘凡例の表示
With ActiveChart
.Legend.Border.LineStyle = xlNone
.Legend.Interior.ColorIndex = 2
.Legend.Interior.PatternColorIndex = 1
.Legend.Interior.Pattern = xlSolid
.Legend.Width = 93
.Legend.Height = 83
.Legend.Top = 61
.Legend.Left = 75
‘.Legend.Position = xlBottom
‘.Legend.Position = xlCorner
‘.Legend.Position = xlTop
‘.Legend.Position = xlRight
‘.Legend.Position = xlLeft
End With ‘ActiveChart
 凡例の削除  Dim i as integer
For i = 1 To 5
.Chart.Legend.LegendEntries(1).Delete ‘凡例は系列の順番が繰り上がるので，1番目に来るものを5回消す
Next i
 Y軸の設定  With ActiveChart
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = “Y軸”
.Axes(xlValue).AxisTitle.Left = 100 ‘Y軸名の配置左側
.Axes(xlValue).AxisTitle.Top = 20 ‘Y軸名の配置上側
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScaleIsAuto = True
.Axes(xlValue).MinorUnitIsAuto = True
.Axes(xlValue).MajorUnit = 0.005 .Axes(xlValue).Crosses = xlAutomatic
.Axes(xlValue).HasMajorGridlines = True
.Axes(xlValue).HasMinorGridlines = False
.Axes(xlValue).Crosses = xlAutomatic
.Axes(xlValue).DisplayUnit = xlNone
.Axes(xlValue).ReversePlotOrder = False
.Axes(xlValue).ScaleType = xlLinear
.Axes(xlValue).TickLabels.NumberFormatLocal = “0.000_ ”
End With ‘ActiveChart
 X軸の設定  With ActiveChart
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = “X軸”
.Axes(xlCategory).AxisTitle.Left = 10 ‘X軸名の配置左側
.Axes(xlCategory).AxisTitle.Top = 20 ‘X軸名の配置上側
.Axes(xlCategory).TickLabels.Alignment = xlCenter
.Axes(xlCategory).TickLabels.Offset = 0
.Axes(xlCategory).TickLabels.ReadingOrder = xlContext
.Axes(xlCategory).TickLabels.Orientation = xlVertical
.Axes(xlCategory).HasMajorGridlines = False
.Axes(xlCategory).HasMinorGridlines = False
.Axes(xlCategory).Crosses = xlCustom
.Axes(xlCategory).CrossesAt = -10
End With ‘ActiveChart
 球グラフの作成  With ActiveSheet.ChartObjects.Add(100, 100, 200, 230) ‘シートの横位置，縦位置，グラフの横幅，縦幅
‘なぜか，いきなり可変データを参照させるとバブルグラフが描けないので，
‘一度ダミーデータを入力する。
.Chart.SetSourceData Source:=Sheets(“”球グラフ””).Range(“”B2:D5″”), PlotBy:= _
xlColumns
‘グラフの種類の設定
.Chart.ChartType = xlBubble
‘本当のデータを参照する。
.Chart.SetSourceData Source:=Sheets(“”球グラフ””).Range(Cells(n – 25, 2), Cells(n – 1, 4)), PlotBy:= _
xlColumns
‘グラフを球グラフシートに配置
.Chart.Location Where:=xlLocationAsObject, Name:=””球グラフ””
End With
 グラフ系列の設定  With ActiveChart.SeriesCollection(1)
.Values = myRngAH
.ChartType = xlXYScatter
.MarkerBackgroundColorIndex = xlNone
.MarkerForegroundColorIndex = 8
.MarkerStyle = xlCircle
.Smooth = False
.MarkerSize = 5
.Shadow = False
.Name = “=””測定結果”””
.Border.ColorIndex = 1
.Border.LineStyle = xlContinuous
.Border.Weight = xlThin
End With
 グラフ系列の設定（棒グラフの塗りつぶし）  ActiveChart.SeriesCollection.NewSeries
With ActiveChart.SeriesCollection(1)
.Interior.Pattern = xlSolid
.Interior.ColorIndex = 19
.Fill.Visible = True
End With
 ExcelのColorIndex番号

選択色 .ColorIndex 選択色 .ColorIndex 選択色 .ColorIndex
1 1 15 36 28 41
2 9 16 51 29 33
3 3 17 10 30 37
4 7 18 50 31 55
5 38 19 4 32 47
6 53 20 35 33 13
7 46 21 49 34 54
8 45 22 14 35 39
9 44 23 42 36 56
10 40 24 8 37 16
11 52 25 34 38 48
12 12 26 11 39 15
13 43 27 5 40 2
14 6
 塗りつぶしパターンの設定  With ActiveChart.SeriesCollection(1) ‘系列1について
.Fill.Patterned Pattern:= msoPattern5Percent ‘塗りつぶしパターン
.Fill.Visible = True
.Fill.ForeColor.SchemeColor = 1 ‘前景の色
.Fill.BackColor.SchemeColor = 2 ‘背景の色
End With
 塗りつぶしパターンの設定名

1 msoPattern5Percent 25 msoPatternDashedDownwardDiagonal
2 msoPattern10Percent 26 msoPatternDashedUpwardDiagonal
3 msoPattern20Percent 27 msoPatternDashedHorizontal
4 msoPattern25Percent 28 msoPatternDashedVertical
5 msoPattern30Percent 29 msoPatternSmallConfetti
6 msoPattern40Percent 30 msoPatternLargeConfetti
7 msoPattern50Percent 31 msoPatternZigZag
8 msoPattern60Percent 32 msoPatternWave
9 msoPattern70Percent 33 msoPatternDiagonalBrick
10 msoPattern75Percent 34 msoPatternHorizontalBrick
11 msoPattern80Percent 35 msoPatternPlaid
12 msoPattern90Percent 36 msoPatternDivot
13 msoPatternLightDownwardDiagonal 37 msoPatternDottedGrid
14 msoPatternLightUpwardDiagonal 38 msoPatternDottedDiamond
15 msoPatternDarkDownwardDiagonal 39 msoPatternShingle
16 msoPatternDarkUpwardDiagonal 40 msoPatternTrellis
17 msoPatternWideDownwardDiagonal 41 msoPatternWeave
18 msoPatternWideUpwardDiagonal 42 msoPatternSphere
19 msoPatternLightVertical 43 msoPatternSmallGrid
20 msoPatternLightHorizontal 44 msoPatternLargeGrid
21 msoPatternNarrowVertical 45 msoPatternSmallCheckerBoard
22 msoPatternNarrowHorizontal 46 msoPatternLargeCheckerBoard
23 msoPatternDarkVertical 47 msoPatternOutlinedDiamond
24 msoPatternDarkHorizontal 48 msoPatternSolidDiamond
 処理の分岐・繰り返し
 Yes/Noメッセージボックス表示  RMsg = MsgBox(“＜注意＞１．この処理は元に戻せません。実行前に保存することをお勧めします。” _
& Chr(13) & “処理を実行しますか？” _
& Chr(13) & “実行：<はい(Y)>ボタン” _
& Chr(13) & “中止：<いいえ(N)>ボタン”, vbYesNo)
If RMsg = 7 Then Exit Sub
 メッセージボックスの表示  MsgBox”＜注意＞１．この処理は元に戻せません。実行前に保存することをお勧めします。”
 インプットボックスの表示  Dim CopCell As String ‘コピーセル，ペーストセル指定用の変数
CopCell = Application.InputBox(“コピーするセルを指定してください。” _
& Chr(13) & Chr(13) & “例) S2 (半角英数字)”) ‘コピー開始行
If CopCell = Empty Then Exit Sub
 inputboxで選択範囲指定  Dim myRng As Range
On Error Resume Next
Set myRng = Application.InputBox(“”気温データ範囲を選択。タイトル行は含まない””, Type:=8)
If myRng Is Nothing Then Exit Sub’Type型：省略可。省略すると文字列として認識。
‘下記に示す値の中から1つ，または複数の値の合計値を指定する。数値と文字列なら1+2=3を指定する。
‘0:数式, 1:数値, 2:文字列(テキスト), 4:論理値(TrueまたはFalse), 8:セル参照(Rangeオブジェクト), 16:エラー値(#N/Aなど), 64:数値配列
 セレクトケース  Select Case ns
Case 1 ‘nsが1のときCase ElseEnd Select
 処理の分岐  Dim Dtype As Integer
Dtype = Application.InputBox(“ヒストグラム図を作成しますか？(半角数字)” _
& Chr(13) & Chr(13) & “作成しない場合は1” _
& Chr(13) & Chr(13) & “作成する場合は2”, Type:=1)
If Dtype = Empty Then Exit Sub
 数値か否か判断  If Not IsNumeric(Sheets(1).Range(“”G1″”)) Then ‘文字ならTrueを返す
Else
a = 5 + Sheets(1).Range(“”G1″”).Value
End If
 空シートかどうか判断  WorksheetFunction.CountA(Workbooks(“記録.xls”).Sheets(n).Cells) > 0
 空セルの確認  If Range(“B3”).Value = Empty Then
Else
End if
 Do while ～ loopで「～が真」なら繰り返す  Do While AHC < 12
Loop
 Do ～ LoopをIfで繰り返しを判定する  Do
If Range(“A” & AHR).Value >= 12 Then
Exit Do ‘繰り返しを停止する
Else
AHR = AHR + 1 ‘1行ずつ下げる
End If
Loop
  ユーザーフォーム関連
 ユーザーフォームの表示  Public Sub 系列パターンの設定()
UserForm1.Show ‘UserForm1の表示
End Sub
 テキストボックスの文字取得  Dim Cs As String ‘コピーセル，ペーストセル指定用の変数
Cs = TextBox1.Text
If Cs = Empty Then Exit Sub
 テキストボックスの値取得  Dim Cr As Integer
Cr = TextBox6.Value
If PasR = Empty Then Exit Sub
 テキストボックスの値を数値化  Dim Pnum as double
Pnum = Val(TextBox2.Value)
 ユーザーフォームのオプションボタンのキャプションと事前の選択  Private Sub UserForm_Initialize()
OptionButton1.Caption = “”下””
OptionButton1.Value = True
End Sub
 コンボボックスへの選択肢設定  Private Sub UserForm_Initialize()
ComboBox1.AddItem “ＭＳ Ｐゴシック”
ComboBox1.AddItem “ＭＳ Ｐ明朝”
End Sub
 コメント関連
 コメント一括削除  Sub コメント一括削除() ‘すべてのコメントを削除する
Dim Memo As Comment
Dim RMsg As Integer
For Each Memo In ActiveSheet.Comments
Memo.Delete
Next Memo
End Sub
 コメントを表示する  Application.DisplayCommentIndicator = xlCommentAndIndicator
 コメントの赤いマークのみ表示する  Application.DisplayCommentIndicator = xlCommentIndicatorOnly
 コメントも赤いマークも表示しない  Application.DisplayCommentIndicator = xlNoIndicator
 ファイル操作
 アクティブにする  Workbooks(“記録.xls”).Sheets(1).Activate
 開く  Workbooks.Open Filename:=myPath & “\” & StrWb, Local:=True ‘ブックを開く。
 ファイルの新規作成と保存  Workbooks.Add
ActiveWorkbook.SaveAs Filename:=myPath & “\CHJP.xls”
 閉じる  Workbooks(“記録.xls”).Close
 ファイルを保存せずに閉じる  Workbooks(“日足データ完成版.xls”).Close SAVECHANGES:=False
 上書き保存  Workbooks(“記録.xls”).Save
 シート操作
 シートのコピペ  Workbooks(“記録.xls”).Sheets(1).Copy After:= Workbooks(“記録.xls”).Sheets(1) ‘Wb2のシートをコピーして，Wb1のシートの後にペースト
 シートをアクティブにする  Workbooks(“記録.xls”).Sheets(1).Activate
 シートの削除  Application.DisplayAlerts = False
Workbooks(“CHJP.xls”).Sheets(“Sheet1”).Delete
Application.DisplayAlerts = True
 ワークシートのセルを全削除  Worksheets(1).Cells.Clear
 行・列操作
 列のコピペ1  Columns(“A:E”).Copy
Range(“D1”).Select
ActiveSheet.Paste
Application.CutCopyMode = False
 列のコピペ2  Sheets(1).Range(“A1:B3”).EntireColumn.Copy
Sheets(1).Cells(1,2).PasteSpecial Paste:=xlPasteAll
 行のコピペ  Sheets(1).Rows(“3:5”).Copy
Sheets(2).Range(“A4”).PasteSpecial Paste:=xlPasteAll
 セル操作
 選択範囲をサイズ変更  Cells(3, 2).Resize(2, 3).Copy ‘B3を選択後，選択範囲を””B3:D4″”の2行3列に変更
 セルの値のみ貼り付け  Wb2.Sheets(1).Range(“B3”).Copy
Wb1.Sheets(1).Range(“A2”).PasteSpecial Paste:=xlPasteValues
 セルの値のみ貼り付け2  Sub 値ペースト()
On Error Resume Next
Selection.PasteSpecial Paste:=xlValues
On Error GoTo 0
End Sub
 セルの全て貼り付け  Wb1.Sheets(1).Range(“A1”).PasteSpecial Paste:=xlPasteAll
 結合  Application.DisplayAlerts = False
Wb2.Sheets(1).Range(“S2:U3”).Merge
Application.DisplayAlerts = True
 結合解除  Wb2.Sheets(n).Range(Fnum).UnMerge
 水平配置設定  Wb2.Sheets(n).Range(Fnum).HorizontalAlignment = xlCenter
 垂直配置設定  Wb2.Sheets(n).Range(Fnum).VerticalAlignment = xlCenter
 指定したものをカウントする  Dim n as Integer
n = WorksheetFunction.CountIf(Range(“C2:C100”), “F”) ‘指定セルにあるFのカウント
 一度でも使用したセル全て選択  ActiveSheet.UsedRange ‘アクティブシートの一度でも使用したセル全て選択
 セル内改行の式  Chr(10)
 普通の改行  Chr(13)
 選択範囲の文字列になっている数値を，数値形式に変換する  Sub 文字列を数値に変換()
For Each xCell In Selection
xCell.Value = xCell.Value
Next xCell
End Sub
 選択範囲の数値の前に’をつけて文字列に変換する  Sub 数値を文字列に変換()
For Each xCell In Selection
xCell.Value = “”‘”” & xCell.Value
Next xCell
End Sub
 項目の並べ替え  Wb.Worksheets(“”クロス””).Range(“A1:A120”).Sort _
Key1:= Range(“A1”), Order1:=xlAscending, Orientation:=xlTopToBottom, _
Header:=xlYes’先頭はタイトル行か否か
xlYes ‘先頭はタイトル行
xlNo ‘先頭からデータ’並べ替えの昇順と降順
xlAscending ‘昇順
xlDescending ‘降順’行か列の並べ替え
xlTopToBottom ‘行単位
xlLeftToRight ‘列単位’大文字と小文字の区別
MatchCase:= True

‘ふりがなの使用
MatchCase:= TruexlPinYin ‘ふりがなを使う
xlStroke ‘ふりがなを使わない
 頻出コード
 空じゃないシートだけプログラムを実行する  For n = 1 To Wb2.Sheets.Count
If WorksheetFunction.CountA(Wb2.Sheets(n).Cells) > 0 Then
Wb2.Sheets(1).Copy After:=Wb1.Sheets(1)
End If
Next n
 フォルダ内の全ブック全シートに実行する  Dim StrWb As String ‘フォルダ内のブック名
Dim myPath As String ‘パス名
Dim Wb1, Wb2 As Workbook ‘マクロのブック用変数，開くブック用変数
myPath = ThisWorkbook.Path ‘このプログラムのブックのパス名取得StrWb = Dir(myPath & “\*.csv”)
Set Wb1 = ThisWorkbook ‘Wb1という変数に置き換える
Do While StrWb <> ”
If StrWb <> Wb1.Name Then ‘ブックが自分自身の時は除く
Workbooks.Open Filename:=myPath & “\” & StrWb, Local:=True ‘Dirで取り出したブックを開く
Set Wb2 = Workbooks(StrWb)
‘*******************************************************************
‘********** 他のファイルのデータのコピーとペースト開始 ********
‘*******************************************************************For n = 1 To Wb2.Sheets.Count
If WorksheetFunction.CountA(Wb2.Sheets(n).Cells) > 0 Then ‘空シートのチェック
Wb2.Sheets(1).Copy After:=Wb1.Sheets(1)
End If
Next n’*******************************************************************
‘********** 他のファイルのデータのコピーとペースト終了 ********
‘*******************************************************************

Wb2.Close

End If
StrWb = Dir()
Loop
 シート選択エラーの場合に新規作成  On Error GoTo シート作成 ‘選択するシートがなかった場合に，新規作成するコードへ飛ぶ
Wb1.Sheets(“シート確認”).Activate
On Error GoTo 0
Exit Subシート作成:
Wb1.Activate
Worksheets.Add After:=Sheets(Wb1.Sheets.Count)
ActiveSheet.Name = “シート確認”
Resume Next
End Sub
 セル範囲の設定とデータの確認  Dim Rng As Range ‘使用範囲用の変数
Set Rng = Worksheets(1).Range(“”A1″”).CurrentRegion ‘使用範囲すべて
If Rng Is Nothing Then
MsgBox “”選択範囲にデータがありません。””
Exit Sub ‘**
Else
End If
 配列
 範囲で取得したものを配列として格納  Dim Rng As Range ‘使用範囲用の変数
Dim RagList As Variant ‘データを格納する配列変数
Set Rng = Worksheets(1).Range(“”A1″”).CurrentRegion ‘使用範囲すべて
RagList = Rng ‘配列の設定
P = RagList (2, 4) ‘配列から2行4列のデータを呼び出し
 配列のデータを大きい順に並べ替える  Dim i, x, r, y As Integer
Dim myStr(2, 5), myStrTemp As Variant ‘2,5の配列を定義For x = 0 To UBound(myStr, 2) ‘配列の2次元目の最大Index数を取得（Indexは0から始まるから，この場合は4）
For r = x + 1 To UBound(myStr, 2)
If myStr(0, x) < myStr(0, r) Then ‘2次元目のデータの大きさを比較して，要素を並べ替え
For y = 0 To UBound(myStr, 1)
myStrTemp = myStr(y, x)
myStr(y, x) = myStr(y, r)
myStr(y, r) = myStrTemp
Next
End If
Next
Next
 連想配列関連  Dim Dic As Object ‘色項目用の連想配列変数
Dim n As Integer
Dim v As Variant ‘配列呼び出し用変数Set Dic = CreateObject(“”Scripting.Dictionary””) ‘連想配列の設定’Add(key,item) keyが存在するとエラーになるので，エラー処理しておく。
On Error Resume Next ‘取得したデータが重複する場合は無視
Dic.Add 1, “”熱”” ‘1に熱を割り当て
Dic.Add 2, “”空気”” ‘2に空気を割り当て
On Error GoTo 0 ‘エラー処理の解除n=Dic.Count ‘連想配列に格納されたy要素数の呼び出し
n = Dic.Item(2) ‘2で空気を呼び出し
Dic.Item(2) = “”光”” ‘2に光を新しく関連付ける。空気は無くなる。
Dic.Key(2) = 3 ‘2に3に変更。2は無くなる。Dic.Item(3)で，光が呼び出される。

If Dic.Exists(2) Then ‘keyが存在するか確認。今の場合，falseになる。

v= Dic.keys ‘keyを配列にする。今の場合，「1，3」の配列
P = v(0) ‘配列の呼び出し。Pは1に設定される。

v = Dic.Items ‘itemを配列にする。今の場合，「熱，光」の配列
P = v(0) ‘配列の呼び出し。Pは熱に設定される。

Dic.Remove(1) ‘1と熱の削除
Dic.RemoveAll ‘keyとitemの全削除
 連想配列への格納と呼び出しフォーマット  Dim Dic As Object ‘シート名用の連想配列変数
Dim Buf As String ‘シート名用の変数
Dim Keys As Variant ‘シート名呼び出し用の変数
Dim n As LongSet Dic = CreateObject(“Scripting.Dictionary”) ‘シート名用の連想配列For n = 1 To Wb2.Sheets.Count
Buf = Wb2.Sheets(n).Name ‘シート名の取得
On Error Resume Next
Dic.Add Buf, Buf ‘取得したデータが重複しない場合は配列に登録
On Error GoTo 0
Next nKeys = Dic.Keys ‘配列キーの設定
For n = 0 To Dic.Count – 1 ‘配列Dicの要素数のカウント。配列は0から始まるので，(要素数-1)番まである
On Error GoTo シートなし ‘選択するシートがなかった場合に，新規作成するコードへ飛ぶ
Wb1.Sheets(Keys(n)).Activate ‘配列の呼び出し
On Error GoTo 0

On Error GoTo 次シート ‘選択するシートが無かったら，無視して次へ
Wb2.Sheets(Keys(n)).Activate
On Error GoTo 0
Next n

Exit Sub

次シート:
Resume Next

シートなし:
Wb1.Activate
Worksheets.Add After:=Sheets(Wb1.Sheets.Count)
ActiveSheet.Name = Keys(n)
Resume Next

End Sub
 頻出コード
 VBAでマクロを走らせる  Application.Run “書籍検索マクロ.xls!BookSearch”
 特定の文字を含むか判定  Application.Run “書籍検索マクロ.xls!BookSearch”If InStr(“ABC”, “A”) > 0 Then ‘「ABC」が「A」を含むか
End If
 ハイパーリンクの有無の確認とリンク先URLの取得  If Cells(1, 1).Hyperlinks.Count = 1 Then ‘ハイパーリンクの有無判定
Cells(1, 3).Value = Cells(1, 1).Hyperlinks(1).Address
End If
 セルを特定文字でデータ区切り  Application.DisplayAlerts = False ‘セルを区切るときの警告非表示
Columns(“D:D”).Select
Selection.TextToColumns Other:=True, OtherChar:=”@” ‘@マークで区切る
Application.DisplayAlerts = True ‘セルを区切るときの警告表示
 キーストロークをする関数を定義  ‘各キーのキーコードはどこかを参照
Public Declare Sub Sleep Lib “kernel32” (ByVal dwMilliseconds As Long)
Public Declare Sub keybd_event Lib “user32″ (ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long)
Public Const VK_RETURN = 13
Public Const VK_SHIFT = 16
Public Const VK_CONTROL = 17
Public Const vbKeyMenu = 18
Public Const VK_ESCAPE = 27
Public Const vbKeyTab = 9
Public Const vbKeyLeft = 37
Public Const vbKeyRight = 39
Public Const vbKeyReturn = 13
Public Sub gSub_ExSendKeys(uKeyCode_1 As Integer, Optional uKeyCode_2 As Variant)’キーコードを送信(keybd_event)
”ARG1＝キーコードを指定(1～254)
”ARG2＝キーのハードウェアスキャンコードを指定(0を指定しとけばいいです)
”ARG3＝動作の指定(0：キーダウン／2：キーアップ)
”ARG4キーストロークに関連した32bit追加情報を指定(0を指定しとけばいいです)
If IsMissing(uKeyCode_2) Then
‘キーダウン命令
Call keybd_event(CByte(uKeyCode_1), 0, 0, 0)
‘キーアップ命令
Call keybd_event(CByte(uKeyCode_1), 0, 2, 0)
Else
‘複合キーの場合(Ctrl＋C など)
‘１つ目のキーダウン命令
Call keybd_event(CByte(uKeyCode_1), 0, 0, 0)
‘２つ目のキーダウン命令
Call keybd_event(CByte(uKeyCode_2), 0, 0, 0)
‘２つ目のキーアップ命令
Call keybd_event(CByte(uKeyCode_2), 0, 2, 0)
‘１つ目のキーアップ命令
Call keybd_event(CByte(uKeyCode_1), 0, 2, 0)
End IfEnd Sub

‘****************************************************************
‘************ 以下は実際の導入例 *************
‘****************************************************************

Sub キーストローク()
Call gSub_ExSendKeys(17, 87) ‘[Ctrl] + [W]を押してタブを閉じる
Call gSub_ExSendKeys(17, 80) ‘[Ctrl] + [P]で印刷ウィンドウ表示
Call gSub_ExSendKeys(vbKeyTab) ‘tabを押す。名前を付けて保存ダイアログ表示
Call gSub_ExSendKeys(vbKeyReturn) ‘Enterを押す。名前を付けて保存ダイアログ表示
‘Call gSub_ExSendKeys(1)
‘Call gSub_ExSendKeys(17, 87) ‘[Ctrl] + [W]を押してタブを閉じる
‘Call WaitFor(1)
End Sub
 IEを起動し，  Sub IE操作の基本()
 特定URLを開き，  Dim ie As Object ‘ＩＥオブジェクト用変数
 IEを終了する  Set ie = CreateObject(“InternetExplorer.application”) ‘IEのオブジェクトを作る
ie.Visible = True ‘ＩＥオブジェクト表示
ie.Navigate http://www.google.co.jp/ ‘特定URLを開く
waitIE ie ‘IEのビジー待ち’ IEを終了する
ie.Quit
Set ie = Nothing
End subSub waitIE(ie)
‘ http://www.excel.studio-kazu.jp/kw/20070219032632.html
‘ http://www.ken3.org/cgi-bin/group/vba_ie.asp#Document_ReadyState_Busy
Do While ie.Busy = True Or ie.readystate ≥> 4
DoEvents
Loop

Sleep 100
End Sub
 Googleでキーワードを検索するURL  ‘「飛田」と「国人」をキーワードとして検索する場合
http://www.google.co.jp/search?q=飛田+国人
 開いたURLに含まれるリンク数を取得  ie.Document.Links.Length
 リンク部分の情報を取得する  ‘リンクの配列は，0から始まることに留意する。かつ，数値が0から始まる場合には，それが省略されてしまうので，文字列化している。
Cells(2, “A”) = “‘” & ie.Document.Links(0).Href ‘リンク先
Cells(2, “B”) = “‘” & ie.Document.Links(0).OuterText ‘自分を含む テキスト(Innerと変わりない？)
Cells(2, “C”) = “‘” & ie.Document.Links(0).OuterHTML ‘自分を含む HTML
Cells(2, “D”) = “‘” & ie.Document.Links(0).InnerText ‘内側のテキスト
Cells(2, “E”) = “‘” & ie.Document.Links(0).InnerHTML ‘内側のHTML
Cells(2, “F”) = “‘” & ie.Document.Links(0).Target ‘_Blank や 表示先フレームの名前など
 検索キーワードをURLコード化  Dim SerchWord As String
Dim JS As Object
Set JS = CreateObject(“ScriptControl”)
JS.Language = “JScript”
SerchWord = JS.CodeObject.encodeURIComponent(Sheet1.Cells(1, 1).Text)
 Amazonの書籍情報の取得  Set Items = XMLData.getElementsByTagName(“Items”)(0)
Set ItemAttributes = Items.getElementsByTagName(“ItemAttributes”)(0)Sheets(“検索”).Cells(3, 1) = ItemAttributes.getElementsByTagName(“Title”)(0).Text
Sheets(“検索”).Cells(3, 2) = ItemAttributes.getElementsByTagName(“Publisher”)(0).Text
‘ISBN-10の有無確認
If ItemAttributes.getElementsByTagName(“ISBN”)(0) Is Nothing Then
Else
Sheets(“検索”).Cells(3, 3) = ItemAttributes.getElementsByTagName(“ISBN”)(0).Text ‘ISBN-10
End If’ISBN-13の有無確認
If ItemAttributes.getElementsByTagName(“EAN”)(0) Is Nothing Then
Else
Sheets(“検索”).Cells(3, 4) = ItemAttributes.getElementsByTagName(“EAN”)(0).Text ‘ISBN-13
End If

Sheets(“検索”).Cells(3, 5) = Items.getElementsByTagName(“ASIN”)(0).Text ‘ASIN

Sheets(“検索”).Cells(3, i + 6) = ItemAttributes.getElementsByTagName(“Author”)(0).Text
 文字列の位置を取得  Dim n as Integer
n = InStr(Cells(1, 4), “tobi”) ‘文字位置の特定
 Webページをmhtファイルとして保存  Dim msg As Object ‘ // CDO.Message
Dim stm As Object ‘ // ADODB.Stream
Dim outFilename As String
url = “mhtファイルとして保存したいページのURL”Set msg = CreateObject(“CDO.Message”)
msg.CreateMHTMLBody url, cdoSuppressNone, “”, “”Set stm = msg.GetStream
stm.SaveToFile outFilename, adSaveCreateOverWrite
stm.Close

Set stm = Nothing
Set msg = Nothing
 HTMLソースをtxtファイルとして保存  Public Sub HTMLソースの保存()

Dim charSet As String
Dim FILE_NAME As String
Dim m As Integer
FILE_NAME = ThisWorkbook.Path & “\1.txt”

url = “取得したいHTMLソースのURL”

Dim xmlHttp

Set xmlHttp = CreateObject(“Msxml2.XMLHTTP”)

xmlHttp.Open “GET”, url, False ‘urlのソース取得
xmlHttp.send

Dim html As String
html = xmlHttp.ResponseBody
html = StrConv(html, vbUnicode) ‘コードをS-jisからunicodeに変更
Set xmlHttp = Nothing

Dim intFF As Integer

intFF = FreeFile　’ FreeFile値の取得
Open FILE_NAME For Output As #intFF
Print #intFF, html ‘htmlソースを出力

投稿日時：08/16/2018 9:56 PM　

カテゴリー：