トップ 差分 一覧 カテゴリ ソース 検索 ヘルプ RSS ログイン

ScrapCode/VBA/ExcelVBA

INDEX

Excel VBA のちょっとしたマクロ集

Microsoft Office Excel マクロ

Excel 用のマクロ

 CSV一括読み込み

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Option Explicit

Sub CSV一括読み込み()
' 選択したディレクトリのすべてのCSVファイルを読み込み、
' ブックにCSVのシートを追加します。
    Dim book As Workbook
    Dim base As String
    Dim file As String
    
    ' ブックと同じ場所
    'base = ThisWorkbook.Path
    
    ' フォルダ選択ダイアログ
    Dim dialog As FileDialog
    Set dialog = Application.FileDialog(msoFileDialogFolderPicker)
    dialog.Title = "CSV一括読み込み 対象フォルダ選択"
    If Not dialog.Show Then Exit Sub ' キャンセルは終わり
    base = dialog.SelectedItems(1)
    
    If Right(base, 1) <> "\" Then base = base & "\" ' 末尾に \ を追加
    file = Dir(base & "*.csv") ' 一致する最初のファイルを取得
    Do Until file = ""
        If Not GetAttr(base & file) And vbDirectory Then
           ' CSVを開き、そのブックをコピー
           Set book = Workbooks.Open(base & file)
           book.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
           book.Close False
           Set book = Nothing
        End If
        
        file = Dir() ' 次のファイルを取得
    Loop
End Sub

 シート一覧作成

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Option Explicit

Sub シート一覧作成()
' カレントシートにシート名の一覧を作ります。
' カレントセルから下方向へ、他のシートのシート名を書き出し、
' そのシートへのハイパーリンクを設定します。
    Dim sheet As Worksheet
    
    Dim listSheet As Worksheet
    Set listSheet = ActiveWorkbook.ActiveSheet
    
    For Each sheet In ActiveWorkbook.Sheets
        If sheet.Name <> listSheet.Name Then
            ' シート名を設定
            ActiveCell.Value = sheet.Name
            ' シート名にハイパーリンクを設定
            listSheet.Hyperlinks.Add _
                Anchor:=ActiveCell, _
                Address:="#'" & sheet.Name & "'!A1", TextToDisplay:=sheet.Name
            
            ActiveCell.Offset(1, 0).Activate ' 下へ移動
        End If
    Next sheet
    ActiveCell.Value = "" ' シート数が少ないときに境目がわかるようにすぐ下はクリア
    
    Set sheet = Nothing
End Sub

 マクロ呼び出し一覧作成

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Option Explicit

Sub マクロ呼び出し一覧作成()
' 指定したシートに各シートのマクロ呼び出しの一覧を作ります。
' 他のシートのシート名と呼び出されるマクロ名を書き出します。
    Dim sheet As Worksheet
    Dim shape As Object
    
    Dim listSheet As Worksheet
    Dim listSheetName As String
    ' 一覧シートの指定
    listSheetName = InputBox(Prompt:="一覧を作成するシート名を指定して下さい。" & vbNewLine _
        & "指定されたシートがない場合は新規作成します。既に存在する場合は、クリアされます。", _
        Default:="マクロ呼び出し一覧")
    If listSheetName = "" Then Exit Sub ' キャンセルは終わり
    
    ' 一覧シートを探す/(なければ)新規作成
    Set listSheet = Nothing
    For Each sheet In ActiveWorkbook.Sheets
        If sheet.Name = listSheetName Then Set listSheet = sheet
    Next sheet
    Set sheet = Nothing
    If listSheet Is Nothing Then
        Set listSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        listSheet.Name = listSheetName
    End If
    ' 一覧シートの初期化
    listSheet.Activate
    listSheet.Cells.ClearContents
    listSheet.Cells.ClearFormats
    listSheet.Cells(1, 1).Activate
    '
    ActiveCell.Value = "マクロ呼び出し一覧"
    ActiveCell.Offset(2, 0).Activate
    
    For Each sheet In ActiveWorkbook.Sheets
        If sheet.Name <> ActiveSheet.Name Then
            ' シート名を設定
            ActiveCell.Value = sheet.Name
            ' シート名にハイパーリンクを設定
            ActiveWorkbook.ActiveSheet.Hyperlinks.Add _
                Anchor:=ActiveCell, _
                Address:="#'" & sheet.Name & "'!A1", TextToDisplay:=sheet.Name
            ActiveCell.Offset(1, 0).Activate ' 下へ移動
            
            For Each shape In sheet.Shapes
                If shape.OnAction <> "" Then
                    ActiveCell.Offset(0, 1).Value = shape.Name
                    ActiveCell.Offset(0, 2).Value = shape.OnAction
                    ActiveCell.Offset(1, 0).Activate ' 下へ移動
                End If
            Next shape
            
            ActiveCell.Offset(1, 0).Activate ' 下へ移動
        End If
    Next sheet
    
    Set shape = Nothing
    Set sheet = Nothing
End Sub

 部分一致リスト

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
'Option Explicit
'
'Private Sub Worksheet_Change(ByVal Target As Range)
'    Call PartialMatchListSet(Target, 3, 5, True, "Sheet4", "テーブル1", 5)
'End Sub
'
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'    Call PartialMatchListSet(Target, 2, 5, False, "Sheet4", "テーブル1", 3)
'End Sub

' 入力規則のリストを部分一致でマッチした内容に設定します。
' 指定したセルに入力された文字に部分一致したものを、入力規則のリストに設定します。
' 引数:Target          対象のセル
' 引数:TargetColumn    対象のカラム位置
' 引数:StartRow        リストを設定する開始行数
' 引数:sheetName   リストの内容があるシート
' 引数:tableName   リストの内容があるテーブル名
' 引数:fieldNo     リストの内容があるテーブルのカラム位置
Sub PartialMatchListSet(ByVal Target As Range, _
        ByVal TargetColumn As Integer, ByVal StartRow As Integer, ByVal PutAll As Boolean, _
        ByVal SheetName As String, ByVal TableName As String, ByVal FieldNo As Integer)
    If Target.Cells.Count > 1 Then Exit Sub ' 複数セルの選択時は抜ける
    If Target.Column <> TargetColumn Or Target.Row <= StartRow Then Exit Sub ' 設定する行・列の位置以外
    
    Target.Validation.Delete ' 入力規則をクリア
    If Not PutAll And Target.Value = "" Then Exit Sub ' セルの値がないときは終わり
    
    ' リスト選択の内容取得
    ' テーブルから部分一致で絞り込み取得する
    Dim filter As String
    filter = "=*" & Target.Value & "*" ' 部分一致の条件
    Dim list As ListObject
    Set list = Worksheets(SheetName).ListObjects(TableName)
    list.ShowAutoFilter = False
    list.Range.AutoFilter Field:=FieldNo, Criteria1:=filter, Operator:=xlAnd
    ' リスト選択の項目取得
    Dim cel As Range, cels As Range, formula As String
    formula = ","
    On Error GoTo ValidateListSeted ' フィルタで対象がないときはエラーになるのでスキップ
    Set cels = list.DataBodyRange.Columns(FieldNo).SpecialCells(xlCellTypeVisible)
    For Each cel In cels
        If cel.Value <> "" Then formula = formula & "," & cel.Value
    Next
    If Len(formula) > 1500 Then formula = ".. Too many .."
ValidateListSeted:
    On Error GoTo 0
    ' リスト選択の入力規則をセット
    Target.Validation.Add Type:=xlValidateList, Operator:=xlEqual, Formula1:=formula
    Target.Validation.ShowInput = False
    Target.Validation.ShowError = False
    
    Set list = Nothing
End Sub

 テーブルデータコピー

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Option Explicit

Sub テーブルデータ末尾コピー()
    Call TableDataCopy
End Sub

' アクティブシートのカーソルのある位置のデータをテーブルの末尾に値をコピーします。
' メソッド実施後、ペースとされた範囲が選択状態となります。
' 引数:startColumnIndex コピーする開始列位置(1〜 セルの列, 0以下は対象テーブルの先頭)
' 引数:endColumnIndex コピーする終了列位置(1〜 セルの列, 0以下は対象テーブルの末尾)
Sub TableDataCopy(Optional StartColumnIndex As Integer = 0, Optional EndColumnIndex As Integer = 0)
    'Dim currentSheet As Worksheet
    'Dim currentCell As Range
    Dim selectRange As Range
    Dim selectTable As ListObject
    Dim newListRow As ListRow
    
    'Set currentSheet = ActiveSheet
    'Set currentCell = ActiveCell
    
    ' 選択されたオブジェクがセルでない
    If TypeName(Application.Selection) <> "Range" Then
        MsgBox "対象データの行を選択して下さい。", vbOKOnly
        Exit Sub
    End If
    ' 選択されたテーブルがない
    Set selectTable = Application.Selection.ListObject
    If selectTable Is Nothing Then
        MsgBox "対象データの行を選択して下さい。", vbOKOnly
        Exit Sub
    End If
    ' 選択されたセル。複数行でない
    Set selectRange = ActiveWindow.RangeSelection
    If selectRange Is Nothing Then
        MsgBox "対象データの行を選択して下さい。", vbOKOnly
        Exit Sub
    ElseIf selectRange.Rows.Count <> 1 Then
        MsgBox "対象データを複数行選択出来ません。", vbOKOnly
        Exit Sub
    End If
    
    ' コピー範囲が未指定の場合は、テーブルの全体
    If StartColumnIndex < 1 Then StartColumnIndex = selectTable.Range.Column
    If EndColumnIndex < 1 Then EndColumnIndex = selectTable.Range.Column + selectTable.Range.Columns.Count - 1
    
    ' 最終行に追加して、選択行のデータをコピー&ペースト
    Set newListRow = selectTable.ListRows.Add
    Range(Cells(selectRange.Row, StartColumnIndex), Cells(selectRange.Row, EndColumnIndex)).Copy
    Range(Cells(newListRow.Range.Row, StartColumnIndex), Cells(newListRow.Range.Row, EndColumnIndex)).PasteSpecial Paste:=xlPasteValues
    Set newListRow = Nothing
    
    Set selectTable = Nothing
    Set selectRange = Nothing
    'Set currentCell = Nothing
    'Set currentSheet = Nothing
End Sub

最終更新時間:2016年12月23日 22時54分44秒 指摘や意見などあればSandBoxのBBSへ。