CollectionとDictionary

Collectionのキーは大文字小文字関係なし、TestとTESTが同じ扱い。
Dictionaryのキーは完全一致。TestとTESTは別物扱い。
以下、ざっくりとした使い方の違い。

Sub DictionaryTest()
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    'Dictionary Add(key, item)
    With dic
        .Add "苗字", "桃"
        .Add "名前", "太郎"
        .Add "住所", "静岡"
        .Add "年齢", 20
    End With
    
    'キーの存在を確認してから削除。
    If dic.Exists("苗字") Then
        dic.Remove "苗字"
    End If
    
    'キーと要素一覧表示。
    Dim v
    For Each v In dic
        Debug.Print v & " : " & dic.Item(v)
    Next
    Debug.Print dic.Count & "個"
    
    Set dic = Nothing
    
End Sub

Sub CollectionTest()
    
    Dim col As Collection
    Set col = New Collection
    
    'Collection Add(item, key)
    With col
        .Add "桃", "苗字"
        .Add "太郎", "名前"
        .Add "静岡", "住所"
        .Add 20, "年齢"
    End With
    
    '追加した関数でキー存在確認してから削除。
    If isExists(col, "住所") Then
        col.Remove "住所"
    End If
    
    '要素一覧表示。キーは出せません。
    Dim var
    For Each var In col
        Debug.Print var
    Next
    Debug.Print col.Count & "個"
    
    Set col = Nothing
    
End Sub


'Collectionにはキー存在確認の関数が無いので追加
Function isExists(c As Collection, key As String) As Boolean
    On Error GoTo err_1
    Call c.Item(key)
    isExists = True
    Exit Function
err_1:
    isExists = False
End Function

以上。

処理の停止

VBA実行中に処理を停止したい時の案。

停止検知時にメッセージボックスでも出せば、再開or終了とかもできそう。

UserForm作ってコマンドボタン2個、ラベル1個配置して以下を張り付け。

'--------------------------------------------------------------------------------

Dim bStop As Boolean 'フラグ

'処理開始
Private Sub CommandButton1_Click()
    
    Dim i As Long
    bStop = False 'フラグ初期化
    
    'Me.CommandButton1.Enabled = False
    'Me.CommandButton2.Enabled = True
    'Me.CommandButton2.SetFocus
    
    For i = 1 To 1000000000
        Me.Label1.Caption = i
        DoEvents
        If bStop = True Then Exit For
    Next
    
End Sub

'処理中止
Private Sub CommandButton2_Click()
    bStop = True
    'Me.CommandButton1.Enabled = True
    'Me.CommandButton2.Enabled = False
    'Me.CommandButton1.SetFocus
End Sub

'フォーム終了時にもフラグを立てる
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    bStop = True
End Sub

処理の停止

VBA実行中に処理を停止したい時の案。
停止検知時にメッセージボックスでも出せば、再開or終了とかもできそう。

UserForm作ってコマンドボタン2個、ラベル1個配置して以下を張り付け。

Private Sub CommandButton1_Click()
    
    Dim i As Long
    bStop = False 'フラグ初期化
    
    'Me.CommandButton1.Enabled = False
    'Me.CommandButton2.Enabled = True
    'Me.CommandButton2.SetFocus
    
    For i = 1 To 1000000000
        Me.Label1.Caption = i
        DoEvents
        If bStop = True Then Exit For
    Next
    
End Sub

'処理中止
Private Sub CommandButton2_Click()
    bStop = True
    'Me.CommandButton1.Enabled = True
    'Me.CommandButton2.Enabled = False
    'Me.CommandButton1.SetFocus
End Sub

'フォーム終了時にもフラグを立てる
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    bStop = True
End Sub

BOM有無UTF-8テキストファイルの読み書き

「Option Explicit」マジ大事。適当に書いても動くからVBA厄介デスヨネー。
UTF-8はBOM有で、UTF-8NはBOM無し。
本題。UTF-8はADODBを使って入出力します。FSOもついでに載せときます。

Option Explicit

Public Sub テキストファイルUTF8読み込み(strFilePath As String)

    Dim buf As String, temp As Variant
    Dim iRow As Long, iClm As Long
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Worksheets("読込結果")
    
    '違う文字コードのファイルを読み込むとエラーとなるので必ず回避。
    '回避先でCloseを忘れない。
    On Error GoTo err_1

    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile strFilePath
        Do Until .EOS 'EOFと同義
            buf = .ReadText(-2) '1行ずつ読み込みは-2、全て読み込みは-1又は引数無し
            iRow = iRow + 1
            temp = Split(buf, vbTab) 'タブ区切り
            For iClm = LBound(temp) To UBound(temp)
                ws.Cells(iRow, iClm + 1) = temp(iClm)
            Next
    Loop
err_1:
        .Close
    End With
    
    Set ws = Nothing
    
End Sub

Public Sub テキストファイル読み込みFSO(strFilePath As String)

    Dim buf As String, temp As Variant, lineTemp As Variant
    Dim iRow As Long, iClm As Long
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Worksheets("読込結果")
    
    With CreateObject("Scripting.FileSystemObject")
        With .GetFile(strFilePath).OpenAsTextStream
            buf = .ReadAll '全て読み込む
            .Close
        End With
    End With
    
    lineTemp = Split(buf, vbCrLf) '改行で区切る
    For iRow = LBound(lineTemp) To UBound(lineTemp)
        temp = Split(lineTemp(iRow), vbTab) 'タブ区切り
        For iClm = LBound(temp) To UBound(temp)
            ws.Cells(iRow + 1, iClm + 1) = temp(iClm)
        Next
    Next
    
    Set ws = Nothing
    
End Sub

Public Sub テキストファイル書き出しFSO()

    Dim strFilePath As String
    Dim buf As String
    Dim delimiter As String
    Dim row As Range, clm As Range
    
    Dim ws As Worksheet
    Dim fso As Object
    
    strFilePath = Application.GetSaveAsFilename(InitialFileName:="shift-jis.txt", _
    FileFilter:="テキストファイル(*.txt),*txt,CSVファイル(*.csv),*.csv")
    If strFilePath = "False" Then Exit Sub
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ws = ThisWorkbook.Worksheets("読込結果")
    
    delimiter = vbTab 'タブ区切り
    
    With fso.CreateTextFile(strFilePath)
        
        For Each row In ws.UsedRange.Rows
            
            buf = ""
            For Each clm In row.Columns
                buf = buf & clm.Value
                If clm.Column < row.Columns(row.Columns.Count).Column Then
                    buf = buf & delimiter '最後の列でなければ区切り文字を追加
                End If
            Next
            
            .WriteLine buf
        Next
        
        .Close
        
    End With
    
    Set ws = Nothing
    Set fso = Nothing
    
End Sub

Public Sub テキストファイル書き出しADODB(Optional bom As Boolean = True)
    
    Dim ws As Worksheet
    Dim strFilePath As String
    Dim buf As String
    Dim delimiter As String
    Dim row As Range, clm As Range
    
    strFilePath = Application.GetSaveAsFilename(InitialFileName:="utf-8.txt", _
    FileFilter:="テキストファイル(*.txt),*txt,CSVファイル(*.csv),*.csv")
    If strFilePath = "False" Then Exit Sub
    
    Set ws = ThisWorkbook.Worksheets("読込結果")
    
    delimiter = vbTab 'タブ区切り
    
    With CreateObject("ADODB.Stream")
        
        .Charset = "UTF-8"
        .LineSeparator = -1 '-1:adCRLF, 10:adLF, 13:adCR
        .Open
        
        For Each row In ws.UsedRange.Rows
            
            buf = ""
            For Each clm In row.Columns
                buf = buf & clm.Value
                If clm.Column < row.Columns(row.Columns.Count).Column Then
                    buf = buf & delimiter '最後の列でなければ区切り文字を追加
                End If
        Next
        
        .WriteText buf, 1 '0:adWriteChar, 1:adWriteLine
    Next
    
    
    If Not bom Then
        'UTF-8N（UTF-8 BOM無し）を出力する
        Dim byteData() As Byte
        .Position = 0
        .Type = 1 '1:adTypeBinary(バイナリ), 2:adTypeText(既定値、テキスト)
        .Position = 3 '先頭3Byte(BOM)を回避
        byteData = .Read '書き込み予定データを一時避難
        .Position = 0
        .Write byteData '一時避難データを再設定
        .SetEOS '終了個所を再設定
        .SaveToFile strFilePath, 2 '1:adSaveCreateNotExist(既定値、新規作成), 2:adSaveCreateOverWrite(上書保存)
        .Close
    Else
        'BOM有のUTF-8を出力する
        .SaveToFile strFilePath, 2
        .Close
    End If
    
    End With
    
    Set ws = Nothing
    
End Sub

オブジェクト廃棄のメモ

変数の宣言も廃棄も要らぬ書き方メモ。Withで囲まれている間だけ変数が有効。

Dim buf As String
With CreateObject("Scripting.FileSystemObject")
    With .GetFile("テキストファイルパス").OpenAsTextStream
        buf = .ReadAll
        .Close
    End With
End With

Debug.Print buf

ListViewコントロール

ListViewコントロールはこんな感じ。

通常、ツールボックスには出てません。

こんな感じで出して使う。

テスト作成したプログラム載せときます。
フォームはモードレスで動かす予定。

Private Sub UserForm_Initialize()
    
    With ListView1
        .View = lvwReport 'コントロールの見た目
        .LabelEdit = lvwManual '選択時の編集可否設定
        .HideSelection = False '選択状態維持
        .AllowColumnReorder = True '列幅変更可
        .FullRowSelect = True '行全体選択
        .Gridlines = True '枠線表示
        
        .ColumnHeaders.Add , "_No", "No", 30
        .ColumnHeaders.Add , "_Name", "名前", 80
        .ColumnHeaders.Add , "_Bango", "番号", 110
        .ColumnHeaders.Add , "_Birth", "生年月日", 100
        .ColumnHeaders.Add , "_Keitou", "得意技", 80
        
        With .ListItems.Add
            .Text = 1
            .SubItems(1) = "山田太郎"
            .SubItems(2) = "1234567890"
            .SubItems(3) = "2019/04/26"
            .SubItems(4) = "右投右打"
        End With
        
        With .ListItems.Add
            .Text = 2
            .SubItems(1) = "1"
            .SubItems(2) = "2"
            .SubItems(3) = "3"
            .SubItems(4) = "4"
        End With
        
    End With
    
    With ComboBox1
        .AddItem "名前"
        .AddItem "番号"
        .AddItem "生年月日"
        .AddItem "得意技"
        .ListIndex = 1 '初期選択
        .Style = fmStyleDropDownList '編集不可
    End With
    
End Sub

Private Sub ListView1_DblClick()
    'ListViewをダブルクリックしたときに出力するデータを確認
    Dim iCmb As Integer
    Dim outputTxt As String
    iCmb = ComboBox1.ListIndex + 1
    outputTxt = ListView1.SelectedItem.SubItems(iCmb)
    Selection = outputTxt
End Sub

テキスト一括出力タブ区切り

Sub テキストファイルタブ区切り一括出力()
    
    Dim buf As String '1行
    Dim delimiter As String '区切り文字
    Dim row As Range, clm As Range
    Dim ws As Worksheet
    
    Dim outputTxt As String '全データ
    Dim outputFilePath As String '出力パス
    Dim fileNo As Integer
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    delimiter = vbTab 'タブ区切り
    
    For Each row In ws.UsedRange.Rows
        
        buf = ""
        For Each clm In row.Columns
            buf = buf & clm.Value
            If clm.Column < row.Columns(row.Columns.Count).Column Then
                buf = buf & delimiter '最後の列でなければ区切り文字を追加
            End If
        Next
        
        If outputTxt = "" Then
            outputTxt = buf
        Else
            outputTxt = outputTxt & vbCrLf & buf
        End If
        
    Next
    
    
    '出力処理
    outputFilePath = "C: emp est.txt"
    fileNo = FreeFile()
    Open outputFilePath For Output As #fileNo
    
    Print #fileNo, outputTxt
    
    Close #fileNo
    
End Sub