自分でよく使うコードをまとめたものを置いておく。
例えば「A」というモジュールを作成して、
「a.」と入力すれば候補が出てくるので選ぶだけで完了。
画面更新など
画面更新ON/OFF
Function 描画OFF()
Application.ScreenUpdating = False
End Function
Function 描画ON()
Application.ScreenUpdating = True
End FunctionイベントON/OFF
Function イベントOFF()
Application.EnableEvents = False
End Function
Function イベントON()
Application.EnableEvents = True
End Function自動計算ON/OFF
Function 自動計算OFF()
Application.Calculation = xlCalculationManual
End Function
Function 自動計算ON()
Application.Calculation = xlCalculationAutomatic
End Function画面更新・イベント・自動計算まとめてON/OFF
Function 描画イベント自動計算OFF()
With Application
.ScreenUpdating = False '描画OFF
.EnableEvents = False 'イベントOFF
.Calculation = xlCalculationManual '自動計算OFF
End With
End Function
Function 描画イベント自動計算ON()
With Application
.Calculation = xlCalculationAutomatic '自動計算ON
.EnableEvents = True 'イベントON
.ScreenUpdating = True '描画ON
End With
End Function警告ON/OFF
Function 警告OFF
Application.DisplayAlerts = False
End Function
Function 警告ON()
Application.DisplayAlerts = True
End Functionコピーモード解除
Function コピーモード解除()
Application.CutCopyMode = False
End Function
【VBA】画面更新関連
最終行・最終列
最終行の行番号取得
変数 = 最終行Row(“列アルファベット”)
Function 最終行Row(列アルファベット As String) As Long
Dim col As Long
col = Range(列アルファベット & "1").Column
最終行Row = Cells(Rows.Count, col).End(xlUp).Row
End Function最終行のセルを取得
Set 変数 = 最終行Range(“列アルファベット”)
Function 最終行Range(列アルファベット As String) As Range
Dim col As Long
col = Range(列アルファベット & "1").Column
Set 最終行Range = Cells(Rows.Count, col).End(xlUp)
End Function最終列の列番号取得
変数 = 最終列Col(行番号)
Function 最終列Col(行番号 As Long) As Long
最終列Col = Cells(行番号, Columns.Count).End(xlToLeft).Column
End Function最終列のセルを取得
Set 変数 = 最終列Range(行番号)
Function 最終列Range(行番号 As Long) As Range
Set 最終列Col = Cells(行番号, Columns.Count).End(xlToLeft)
End Function～編集中～
フォルダ・ファイル関係
ファイルのフルパス
C:\Users\ユーザー名\デスクトップ\Book1.xlsm
'このマクロブックのフルパスを取得
ThisWorkbook.FullName
'アクティブなブックのフルパスを取得
ActiveWorkbook.FullNameフォルダパス
C:\Users\ユーザー名\デスクトップ
'このマクロブックのフォルダパスを取得
ThisWorkbook.Path
'アクティブなブックのフォルダパスを取得
ActiveWorkbook.Pathファイル名
Book1.xlsm
'このマクロブックのファイル名を取得
ThisWorkbook.Name
'アクティブなブックのファイル名を取得
ActiveWorkbook.Nameファイルを選択してファイルパスを取得
Function ファイルパス取得 _
(ファイルの説明 As String, _
ファイルの拡張子 As String, _
Optional 開くフォルダ As String) As String
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "対象ファイルを選択してください。"
.Filters.Clear
.Filters.Add ファイルの説明, ファイルの拡張子 '例)"エクセルマクロブック", "*.xlsm"
.InitialFileName = 開くフォルダ '最初に開くフォルダ
.AllowMultiSelect = False '複数選択不可
If .Show = True Then
ファイルパス取得 = .SelectedItems(1) 'ファイルパスを変数に格納
Else
End
End If
End With
End Functionフォルダを選択してフォルダパスを取得
Function フォルダパス取得(Optional 開くフォルダ As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "処理対象フォルダを選択してください。"
.InitialFileName = 開くフォルダ
.AllowMultiSelect = False
If .Show = True Then
フォルダパス取得 = .SelectedItems(1)
Else
End
End If
End With
End Functionファイルのフルパスからフォルダパスのみ取得
Function ファイルパスからフォルダパス取得(ファイルパス As String) As String
Dim n As Long
n = InStrRev(ファイルパス, "\") 'ファイル名とフォルダパスの区切り位置
ファイルパスからフォルダパス取得 = Left(ファイルパス, n) '\まで含む
End Functionファイルのフルパスからファイルパスのみ取得
Function ファイルパスからファイル名取得(ファイルパス As String) As String
Dim n As Long
n = InStrRev(ファイルパス, "\") 'ファイル名とフォルダパスの区切り位置
ファイルパスからファイル名取得 = Mid(ファイルパス, n + 1) 'ファイル名のみ
End Functionフォルダを新規作成
ファイル・フォルダへのリンクを作成
ファイルを開く
フォルダを開く
テキストファイル
フォルダ内の全テキストファイルパス取得
Function フォルダ内の全テキストファイル(フォルダパス As String) As String()
'複数のテキストファイル名を格納する配列変数
Dim FileName As String
FileName = Dir(フォルダパス & "*.txt")
If FileName = "" Then
MsgBox "このフォルダ内にテキストファイルがありません。"
End
End If
'複数のテキストファイルパスを格納する配列変数
Dim list() As String
'テキストファイルのパスをリストに格納
Dim i As Long
Do While FileName <> ""
ReDim Preserve list(i)
list(i) = FileName
i = i + 1
FileName = Dir() 'Dir関数は引数を指定せずに呼ばれると前の指定条件のまま次のファイルを探し,見つからなくなると空白文字列を返
Loop
フォルダ内の全テキストファイル = list()
End Functionファイル名リストを昇順に並び替え
Call バブルソート(list()) 'ファイル名リストを渡す
'==================================================
'ソートのためのAPI読み出し宣言
'Office 32Bit版と64Bit版で条件分岐
'==================================================
#If VBA7 And Win64 Then
Declare PtrSafe Function StrCmpLogicalW Lib "SHLWAPI.DLL" _
(ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
#Else
Declare Function StrCmpLogicalW Lib "SHLWAPI.DLL" _
(ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
#End If
'==================================================
'Windowsの標準機能のAPIを使用
'先に上でAPI読み出し宣言をする
'==================================================
Sub バブルソート(ByRef list() As String) 'ファイル名リストを受け取る
Dim i As Long, j As Long
Dim tmp As String
For i = LBound(list) To UBound(list)
For j = i To UBound(list)
If StrCmpLogicalW(StrConv(list(i), vbUnicode), StrConv(list(j), vbUnicode)) > 0 Then
tmp = list(i)
list(i) = list(j)
list(j) = tmp
End If
Next j
Next i
End Subテキストファイルの行数を取得
Function テキストファイルの行数取得(テキストファイルパス As String) As Long
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.OpenTextFile(テキストファイルパス, 8)
テキストファイルの行数取得 = .Line
.Close
End With
Set FSO = Nothing
End Functionテキストファイルの内容をエクセルに書き出す
Function テキストファイルの指定列を書き出し _
(ファイルパス() As String, _
書き出し開始セル As Range, _
Optional txt指定列 As Long = 6, _
Optional 区切り文字 As String = vbTab)
Dim filePath As String '受け取ったファイルパスを入れる変数
Dim l As Long 'ファイル数分ループ
Dim k As Long: k = 0 '横(列)に並べて入力
For l = LBound(ファイルパス) To UBound(ファイルパス)
filePath = ファイルパス(l)
'テキストファイルを開く
Open filePath For Input As #1
'テキストファイルの行数を取得■■Function■■
Dim iLine As Long
iLine = テキストファイルの行数取得(filePath)
'テキストファイルから1行ずつ読み込み
Dim txt As String
Line Input #1, txt 'ダミーで1行目を読み込んでおく（1行目を書き出さない為）
'テキストファイルをタブ区切りで分割して指定列目だけセルに貼り付けていく
Dim aryLine As Variant '文字列格納用配列変数
Dim i As Long, j As Long
j = 0
For i = 0 To iLine - 6 '最後のいらない行を省く
Line Input #1, txt
aryLine = Split(txt, 区切り文字) '読み込んだ行をタブ区切りで配列変数に格納
書き出し開始セル.Offset(j, 0).Value = aryLine(2) '見出し列
書き出し開始セル.Offset(j, k).Value = aryLine(txt指定列 - 1) '6列目のデータ(配列は0スタート)
j = j + 1
Next i
Close #1
k = k + 1
Next l
End Functionオフセット
'A1から「下に1」「右に1」オフセットしたセル ⇒ B2セル
Range("A1").Offset(1, 1)
リサイズ
'A1 ⇒ A1：B2範囲
Range("A1").Resize(2, 2)
'結合セルがTargetセルになっている場合
Target.Cells(1) '範囲内の最初のセル
Target.Cells(Selection.Count) '範囲内の最後のセル
'値を代入
Range("A1") = Range("A2") '単一セルの場合はValue省略可
Range("A1:C5").Value = Range("A6:C10").Value '複数セルの場合はValue省略不可
'コピーして値で張り付け'
Range("A1").Copy 'コピー
Range("A1").PasteSpecial Paste:=xlPasteValues '値だけペースト
'配列に入れて一括代入
配列 = Range("セル範囲")
Range("配列と同じ範囲") = 配列
For
Dim i As Long
For i = 1 To 10
'繰り返す処理
Next i
Do While
Do While 条件
'条件に当てはまる間は繰り返す処理
Loop
If
'条件に当てはまる時の処理
If 条件 Then
'条件に当てはまる時に実行する処理
End If
'条件に当てはまる時と当てはまらない時の処理
If 条件 Then
'条件に当てはまる時に実行する処理
Else
'条件に当はまらない時に実行する処理
End If
'複数条件
If 条件1 Then
'条件1に当てはまる時に実行する処理
ElseIf 条件2 Then
'条件2に当てはまる時に実行する処理
Else
'全ての条件に当はまらない時に実行する処理
End If
Select Case
Select Case "比較する値"
Case "値1"
'値1のときの処理
Case "値2"
'値2のときの処理
Case Else
'いずれの値でもないときの処理
End Select
セル範囲ソート
'A1:E100範囲をC1を基準に並び替え
Range("A1:E100").Sort Key1:=Range("C1"), order1:=xlAscending '昇順
Range("A1:E100").Sort Key1:=Range("C1"), order1:=xlDescending '降順
'3つまで優先キーを設定できる
Range("A1:E100").Sort _
Key1:=Range("C1"), order1:=xlAscending, _
Key2:=Range("B1"), order2:=xlDescending, _
Key3:=Range("D1"), order3:=xlAscending
'タイマー変数
Dim startTime As Double
Dim endTime As Double
Dim processTime As Double
'開始時間取得
startTime = Timer
■■マクロ処理■■
'終了時間取得
endTime = Timer
'処理時間表示
processTime = endTime - startTime
MsgBox "処理時間：" & processTime
ブックを開いて取得（遅い）
'検索先ワークブックを開いて変数に格納
Dim wb2 As Workbook
Set wb2 = Workbooks.Open(FileName:="ファイルパス", ReadOnly:=True)
Dim ws2 As Worksheet
Set ws2 = wb2.Sheets("シート名")
'開いたブックを保存しないで閉じる
wb2.Close (False)
ブックを開かないで取得（速い）
'他ブックリンク式を代入（最終行検索は不可の為、セル範囲指定で取得する）
With ws2.Range("B1:L500")
.Value = "='\\フォルダパス\[ファイル名.xls]シート名'!B1"
.Value = .Value 'リンクを値に変換
End With
ブックを開かない為、高速で値取得可能ですが以下は不可。 文字列検索などは取り込み後のデータに対して行う。
- シート名検索はできない
- 最終行検索もできない
'ブックとシート名が固定の場合
With ws2.Range("B1:L500") '固定の範囲指定で持ってくる
.Value = "='\\フォルダパス\[ファイル名.xls]シート名'!B1"
.Value = .Value 'リンクを値に変換
End With
選択したブックを開かずにリンクで値取得する方法
- ファイルダイアログでファイルを選択してファイルパスを取得 (FileDialog)
- ファイルパスをリンク形式に変換 (InStrRev, Left, Mid)\フォルダ\Book1.xlsm
↓リンク形式に変換↓“=\\フォルダ\[Book1.xlsm]シート名!A1” - 書き込み先セル範囲に式を代入 (Range, Resize)
- 値で貼り付け直す (.Value = .Value)
'選択したブックの値を取得する場合
Dim FileName As String '選択したファイルパス格納変数
'ファイルダイアログからファイルを選択してファイルパスを取得
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Filters.Add "Excelマクロ有効", "*.xlsm"
.InitialFileName = "最初に開くフォルダパス"
.AllowMultiSelect = False
If .Show = True Then '選択された場合
FileName = .SelectedItems(1) 'ファイルパスを変数に格納
Else '選択されなかった場合
MsgBox "キャンセルしました"
End
End If
End With
'ファイルパス名を文字列検索して「\」が何文字目にあるか見つける（後ろから検索）
Dim num As Long
num = InStrRev(FileName, "\")
'先頭に"='"、\の後ろに"["、最後に"]傾向管理'!A1"を挿入
Dim LinkName As String
LinkName = "='" & Left(FileName, num) & "[" & Mid(FileName, num + 1) & "]シート名'!A1"
'リンク式をセル範囲に代入
Dim rng As Range
Set rng = Target.Cells(1, 1).Offset(2, 0).Resize(183, 12)
rng = LinkName
'リンクを値に変換する
rng.Value = rng.Value
※何万行という処理でなければ3つともあまり差は出ない
Findメソッド
'検索で一致したセルを変数に格納
Dim FindCell As Range
Set FindCell = ws2.Range("F:F").Find(What:="検索値")
'見つかった場合
If Not FindCell Is Nothing Then
'実行したい処理
End If
配列＋For文
'検索値
Dim num As String
num = Target.Value
'検索先のA列を配列に格納
Dim 配列 As Variant
配列 = ws.Range(ws.Range("A1"), ws.Cells(Rows.Count, 1).End(xlUp))
'配列内検索で一致した行をコピーして貼り付け
Dim i As Long
For i = 1 To UBound(配列)
If ws.Cells(i, 1) = num Then
ws.Range(ws.Cells(i, 1).Offset(0, 1), ws.Cells(i, 1).Offset(0, 6)).Copy
Target.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
End If
Next i
MATCH関数を使用
'検索値
Dim num As Long 'Match関数の時はStringではなくてLong型で宣言
num = Target.Value
'検索先のF列をMatch関数で検索
Dim n As Long
On Error Resume Next
n = WorksheetFunction.Match(num, ws2.Range("F:F"), 0)
On Error GoTo 0
If n = 0 Then
MsgBox "『EG" & num & "』は見つかりませんでした。"
End
End If
'一致した行をコピーして貼り付け
ws.Range(ws.Cells(n, 1).Offset(0, 1), ws.Cells(n, 1).Offset(0, 6)).Copy
Target.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
Like演算子
Sub Like演算子で文字列が含まれているか判定する()
If ActiveCell.Value Like "*東京*" Then
MsgBox "○"
Else
MsgBox "×"
End If
End Sub
InStr関数
InStr関数は、ある文字列の中から、指定した文字列を検索して、最初に見つかった位置を返す関数です。見つからなかった場合は「0」を返してきます。見つからなかったときに「0」を返す。
Sub InStr関数で文字列が含まれているか判定する()
If InStr(ActiveCell.Value, "東京") <> 0 Then
MsgBox "○"
Else
MsgBox "×"
End If
End Sub
非表示シートを追加して作業用として使う
'作業用シートを非表示で追加
Dim ws As Worksheet, OldSheet As Worksheet
Set OldSheet = ActiveSheet '現在のアクティブシートを記憶
Set ws = Worksheets.Add 'シートを挿入し変数wsとして操作
ws.Visible = False '挿入したシートを非表示にする
OldSheet.Select 'アクティブシートを元に戻す
With ws
.Range("A1") = 10 '非表示シートのセルに書き込む
'作業用シートを削除
Application.DisplayAlerts = False '確認メッセージを抑止
.Delete '非表示シートを削除
Application.DisplayAlerts = True '確認メッセージを再開
End With
A,B,C…
▼数値に変換してからFor文で+1する
'数値かアルファベットが入力してあるセル値を取得
Dim num As Variant
num = Range("A1").Value
'開始キャビが数値だったらその数値スタートで連番を書き込む
Dim i As Long
If IsNumeric(num) = True Then
For i = 1 To 10
Cells(i, 4) = num
num = num + 1
Next
'開始キャビがアルファベットだったら以下の処理（Function AlphabetCheck）
ElseIf AlphabetCheck(num) = True Then
Dim alp_num As Long
alp_num = Range(num & "1").Column 'アルファベットを列番号に変換
For i = 1 To 10
Cells(i, 4) = NumAlp(alp_num) '変換した列番号をアルファベットに戻して書き込む(Function NumAlp)
alp_num = alp_num + 1 '列番号を＋1増やす
Next
Else
MsgBox "開始キャビNo.欄に数字かアルファベットを入力してください"
End If
値がアルファベットかチェックしてTrue or Falseを返すFunction
（引数にセルValueを指定）
'==================================================
'使い方
'If AlphabetCheck(Range("A1").Value) = False Then
' MsgBox "アルファベットでない文字が含まれています"
' Exit Sub
'End If
'==================================================
Private Function AlphabetCheck(sVal As Variant) As Boolean
Dim lCnt As Long
'入力された文字数分ループする
For lCnt = 1 To Len(sVal)
'A～Z、a～zであるか１文字ずつチェック
If Not (Mid(sVal, lCnt, 1) Like "[A-z]") Then
'アルファベットではない場合、Falseを返却する
AlphabetCheck = False
Exit Function
End If
Next
'全てアルファベットであるため、Trueを返却する
AlphabetCheck = True
End Function
アルファベットを数値に変換して返すFunction
（引数にアルファベットを指定）
'==================================================
'使い方
'変換後 = AlpNum("アルファベット")
'==================================================
Private Function AlpNum(alp As Variant) As Variant
AlpNum = Range(alp & "1").Column '列番号を取得
End Function
数値をアルファベットに変換して返すFunction
（引数に数値を指定）
'==================================================
'使い方
'変換後 = NumAlp("数値")
'==================================================
Private Function NumAlp(num As Variant) As Variant
Dim al As String
al = Cells(1, num).Address(RowAbsolute:=False, ColumnAbsolute:=False) '$無しでAddress取得
NumAlp = Left(al, Len(al) - 1)
End Function
連結
str = "サンプルテキスト" & txt & "sampletext" '変数が混ざっても大丈夫
改行
Dim str As String
str = "一行目" & vbCrLf & "二行目"
Msgbox str
' 一行目
' 二行目
セル内改行
Alt + Enter
Dim str As String
str = "一行目" & vbLf & "二行目"
Range("A1").Value = str
数値を文字列に変換
str = CStr(n) '変数nは数値であること
総文字数を取得
n = Len(対象文字列)
文字の抜き出し
str = Left(対象文字列, n) '対象文字列の左からn文字抜き出す
str = Right(対象文字列, n) '対象文字列の右からn文字抜き出す
str = Mid(対象文字列, n, i) '対象文字列の左からn文字目からi文字抜き出す
置換
str = Replace(対象文字列, 置換前文字, 置換後文字)
'例）半角スペースと全角スペースを取り除く
str = Replace(str, " ", "")
str = Replace(str, " ", "")
変換
str = StrConv(対象文字列, vbNarrow) '半角へ
str = StrConv(対象文字列, vbWide) '全角へ
str = StrConv(対象文字列, vbLowerCase) '小文字へ
str = StrConv(対象文字列, vbUpperCase) '大文字へ
str = StrConv(対象文字列, vbKatakana) 'カタカナへ
str = StrConv(対象文字列, vbHiragana) 'ひらがなへ
文字列が含まれているか
'見つかればその最初の文字数を返し、見つからなければ0を返す
n = InStr(対象文字列, 探す文字列)
最初の一文字目を削除する
Dim rng As Range
For Each rng In Range("A1:A5")
rng.Value = Mid(rng.Text, 2)
Next rng
先頭文字と末尾文字を削除する
Dim rng As Range
For Each rng In Range("A1:A5")
rng.Value = Mid(rng.Text, 2) '先頭文字削除
rng.Value = Left(rng.Text, Len(rng.Value) - 1) '末尾文字削除
Next rng
'A1セルが画面に見えていない場合、A1セルが画面の中心あたりに表示されるように画面移動
Range("A1").Activate
'A1セルが画面の左上にくるように画面移動
Application.Goto Range("A1"), True
'A1セルから右に5移動したA6セルが左上に来るように移動
Application.GoTo Reference:=Range("A1"), Scroll:=True
ActiveWindow.SmallScroll Up:=0, ToRight:=5
'背景色
Range("A1").Interior.Color = vbYellow '黄色
'フォントの色
Range("A1").Font.Color = vbBlack '黒
| 定数名 | 色 |
|---|---|
| vbBlack | 黒 |
| vbWhite | 白 |
| vbRed | 赤 |
| vbYellow | 黄色 |
| rgbWhiteSmoke | 一番薄い灰色 |
| rgbGainsboro | 二番目に薄い灰色 |
| rgbLightYellow | 薄い黄色 |
Dim bs As Borders
Set bs = Range("A1").Borders '上下左右の罫線
bs.LineStyle = xlContinuous '実線
Dim b As Border
Set b = Range("A1").Borders(xlEdgeTop) '上側の罫線
b.LineStyle = xlDouble '二重線
引きたい箇所
| 定数 | 説明 |
|---|---|
| xlDiagonalDown | 範囲内の各セルの左上隅から右下への罫線 |
| xlDiagonalUp | 範囲内の各セルの左下隅から右上への罫線 |
| xlEdgeBottom | 範囲内の下側の罫線 |
| xlEdgeLeft | 範囲内の左端の罫線 |
| xlEdgeRight | 範囲内の右端の罫線 |
| xlEdgeTop | 範囲内の上側の罫線 |
| xlInsideHorizontal | 範囲外の罫線を除く、範囲内のすべてのセルの水平罫線 |
| xlInsideVertical | 範囲外の罫線を除く、範囲内のすべてのセルの垂直罫線 |
種類
太さ
セル範囲を一括で四捨五入する:WorksheetFunction
'小数第三位で四捨五入
Dim rng As Range
Dim numRng As Range
Set numRng = Range(Cells(7, 2), Cells(lastRow, lastCol)) '対象セル範囲
For Each rng In numRng
rng.Value = Application.WorksheetFunction.Round(rng.Value, 3)
Next
マクロ実行時に値を入力してもらう
Dim n As String
n = InputBox(表示文字列, タイトル文字列, デフォルト値)
'例
Dim n As String
n = InputBox("お名前は？", "年齢確認", "")
スポンサーリンク
