ExcelVBAの覚え書き

一つ目

Option Explicit

'Windows APIの宣言（ユーザーフォームを最前面に表示する処理で使用）
#If VBA7 Then
    ' 64ビット版のOffice用の宣言
    'ユーザーフォームを最前面に表示する処理で使用
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal uFlags As Long) As Long
    Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
    ' 32ビット版のOffice用の宣言
    'ユーザーフォームを最前面に表示する処理で使用
    Private 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 uFlags As Long) As Long
    Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1
Private Const HWND_TOPMOST As Long = -1
Private Const HWND_NOTOPMOST As Long = -2
Private Const SWP_NOACTIVATE As Long = &H10

'ユーザーフォームを最前面に表示する処理
Private Sub SetTopMost()
    Dim hWnd As LongPtr
    hWnd = FindWindowA(vbNullString, Me.Caption)
    If hWnd <> 0 Then
        SetWindowPos hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
    End If
End Sub


'ユーザーフォームがアクティブになった際の処理
Private Sub UserForm_Activate()
    SetTopMost
End Sub


'########################
'#　　　　　　　　　    #
'#   仮データ取り込み   #
'#                      #
'########################

'「仮データ取り込み」ボタンをクリックした場合の処理
Private Sub CommandButton2_Click()
    Call InitializeSheet
    ImportUTF8CSV
End Sub


'CSVファイルを取り込む
Sub ImportUTF8CSV()
    Dim conn As Object
    Dim rs As Object
    Dim filePath As String
    Dim sheetName As String
    Dim query As String
    
    'ファイル選択ダイアログを表示してCSVファイルを選択
    filePath = Application.GetOpenFilename("CSVファイル (*.csv), *.csv", , "CSVファイルを選択してください")
    
    ' ファイル選択がキャンセルされた場合は処理を終了
    If filePath = "False" Then Exit Sub
    
    ' データを貼り付けるシート名を指定
    sheetName = "Sheet1"
    
    ' ADODB.Connectionオブジェクトを作成
    Set conn = CreateObject("ADODB.Connection")
    ' ADODB.Recordsetオブジェクトを作成
    Set rs = CreateObject("ADODB.Recordset")
    
    ' CSVファイルへの接続文字列を設定
    conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                            Left(filePath, InStrRev(filePath, "\")) & ";" & _
                            "Extended Properties=""text;HDR=Yes;FMT=Delimited;CharacterSet=65001;"""
    
    ' 接続を開く
    conn.Open
    
    ' クエリを設定
    query = "SELECT * FROM [" & Mid(filePath, InStrRev(filePath, "\") + 1) & "]"
    
    ' クエリを実行してデータを取得
    rs.Open query, conn, 1, 3
    
    ' データをシートに貼り付け
    ThisWorkbook.Sheets("Sheet1").Cells(1, 1).CopyFromRecordset rs
    
    ' 接続とレコードセットを閉じる
    rs.Close
    conn.Close
    
    ' オブジェクトを解放
    Set rs = Nothing
    Set conn = Nothing
    
    ThisWorkbook.Save  ' 現在のファイル名で保存
    
End Sub


'####################
'#  　　　　　　    #
'#  情報入力        #
'#                  #
'####################
Private Sub CommandButton3_Click()
    ' UserForm1を非表示にする
    Me.Hide
    
    ' 入力フォームを表示する
    UserForm2.Show
    
    ' UserForm2が閉じられたらUserForm1を再表示する
    Me.Show
End Sub


'####################
'#  　　　　　　    #
'#   ファイル出力   #
'#                  #
'####################
Private Sub CommandButton4_Click()
    ExportSheetToUTF8CSV
End Sub

' ADOライブラリを参照設定する必要があります
' 参照設定方法: VBAエディタで [ツール] -> [参照設定] -> "Microsoft ActiveX Data Objects X.X Library" にチェックを入れる

Function ConvertSheetToCSVString(sheet As Worksheet) As String
    Dim csvString As String
    Dim row As Range
    Dim cell As Range

    csvString = ""

    For Each row In sheet.UsedRange.Rows
        Dim rowString As String
        rowString = ""

        For Each cell In row.Cells
            rowString = rowString & """" & Replace(cell.Value, """", """""") & """," ' ダブルクオーテーションをエスケープ
        Next cell

        ' 最後のカンマを削除して改行を追加
        rowString = Left(rowString, Len(rowString) - 1) & vbCrLf

        csvString = csvString & rowString
    Next row

    ConvertSheetToCSVString = csvString
End Function

Sub ExportSheetToUTF8CSV()
    Dim sheet As Worksheet
    Dim csvString As String
    Dim filePath As Variant
    Dim stream As Object

    ' 出力するシートを指定
    Set sheet = ThisWorkbook.Sheets("Sheet1") ' "Sheet1" を適切なシート名に変更

    ' CSV文字列に変換
    csvString = ConvertSheetToCSVString(sheet)

    ' ファイル保存ダイアログを表示
    filePath = Application.GetSaveAsFilename(FileFilter:="CSV Files (*.csv), *.csv", Title:="保存先を指定してください")

    ' ユーザーがキャンセルを押した場合の処理
    If filePath = False Then
        MsgBox "保存がキャンセルされました。"
        Exit Sub
    End If

    ' ADOストリームオブジェクトを作成
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2 ' テキストストリーム
    stream.Charset = "utf-8"
    stream.Open

    ' UTF-8 BOMを書き込む
    stream.WriteText ChrW(&HFEFF)

    ' CSV文字列を書き込む
    stream.WriteText csvString

    ' ファイルに保存
    stream.SaveToFile filePath, 2 ' 2 = adSaveCreateOverWrite
    stream.Close

    MsgBox "CSVファイルのエクスポートが完了しました。"
End Sub




'##########################
'#　　　　　　　　  　    #
'#   閉じるボタンの処理   #
'#                        #
'##########################

'閉じるボタンをクリックした場合の処理
Private Sub CommandButton1_Click()
    ' ウィンドウを元に戻してエクセルシートを表示する
    ThisWorkbook.Windows(1).Visible = True
    Application.WindowState = xlMaximized
    
    ' ユーザーフォームを閉じる
    Unload Me
End Sub

二つ目

Option Explicit

Private Sub UserForm_Initialize()
    ' フォーム内のすべてのコントロールのフォントサイズを指定
    Call SetAllControlsFontSize(Me, 14)
    
    '年月日を初期化する
    Date_Initialize
    
    '都道府県コンボボックスを初期化する
    Prefectures_Initialize
    
    
    
End Sub

Private Sub Date_Initialize()
    
    ' ===== 和暦コンボボックスの設定 =====
    '元号を取得
    Dim eras As Collection
    Dim era As Variant
    
    Set eras = GetEraCollection()
    
    '和暦を設定
    For Each era In eras
        cboLostDateFromEra.AddItem era(0) ' 表示文字を追加
        cboLostDateToEra.AddItem era(0)
        cboLostDateFromEra.List(cboLostDateFromEra.ListCount - 1, 1) = era(1) ' コードを隠し追加
        cboLostDateToEra.List(cboLostDateFromEra.ListCount - 1, 1) = era(1)
    Next era
    
    '初期値に令和（4）を設定
    cboLostDateFromEra.ListIndex = 4
    cboLostDateToEra.ListIndex = 4
    
    'リストからの選択だけにする（ユーザー入力を抑止）。
    cboLostDateFromEra.Style = fmStyleDropDownList
    cboLostDateToEra.Style = fmStyleDropDownList
    
    '午前、午後のコンボボックスの設定
    Dim ampm As Collection
    Dim timePeriod As Variant
    
    Set ampm = GetAmPmCollection()
    '和暦を設定
    For Each timePeriod In ampm
        cboLostDateFromAmPm.AddItem timePeriod(0) ' 表示文字を追加
        cboLostDateToAmPm.AddItem timePeriod(0)
        cboLostDateFromAmPm.List(cboLostDateFromAmPm.ListCount - 1, 1) = timePeriod(1) ' コードを隠し追加
        cboLostDateToAmPm.List(cboLostDateToAmPm.ListCount - 1, 1) = timePeriod(1)
    Next timePeriod
    
    '初期値に令和（4）を設定
    cboLostDateFromAmPm.ListIndex = 0
    cboLostDateToAmPm.ListIndex = 0
    
    'リストからの選択だけにする（ユーザー入力を抑止）。
    cboLostDateFromAmPm.Style = fmStyleDropDownList
    cboLostDateToAmPm.Style = fmStyleDropDownList
    
End Sub

'都道府県のコンボボックスの初期化を行う
Private Sub Prefectures_Initialize()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("都道府県等コード")
    
    ' リストの範囲を指定
    Set rng = ws.Range("A2:B48")
    
    
    ' コンボボックスに項目を追加
    With cboPrefecture
        .Clear ' 既存の項目をクリア
        For Each cell In rng.Columns(2).Cells
            If Not IsEmpty(cell.Value) Then
                ' コンボボックスに表示するアイテムを追加
                .AddItem cell.Value
                ' アイテムに対応するデータ（コード）を記録するための設定
                .List(.ListCount - 1, 1) = cell.Offset(0, -1).Value
            End If
        Next cell
        ' 列の幅を調整（オプション）
        .ColumnWidths = "30; 0" ' 表示用の列幅を調整
    End With
    
    '初期値を設定
    cboPrefecture.ListIndex = 33
    
    'リストからの選択だけにする（ユーザー入力を抑止）。
    cboPrefecture.Style = fmStyleDropDownList
    
End Sub

'市区町村コードのDictionalyを作成する
Sub SetCityDictionary()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim dictCities As Dictionary
    Dim dictCityList As Dictionary
    Dim prefCode As String
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("都道府県等コード")
    
    ' リストの範囲を指定
    Set rng = ws.Range("G2:I" & ws.Cells(ws.Rows.Count, "G").End(xlUp).row)
    
    ' 市区町村名の辞書を作成
    Set dictCities = New Dictionary
    
    ' データを辞書に格納
    For Each cell In rng.Columns(1).Cells
        prefCode = Left(cell.Value, 2)
        
        Debug.Print prefCode
        
        If Not dictCities.Exists(prefCode) Then
            Set dictCityList = New Dictionary
            dictCities.Add prefCode, dictCityList
        Else
            'Set dictCityList = dictCities(prefCode)
        End If
        'dictCityList.Add cell.Offset(0, 1).Value, cell.Offset(0, 2).Value
    Next cell
    
    
End Sub








Private Sub cboPrefecture_Change()
    Dim selectedCode As String
    
    ' 選択されたアイテムに対応するコードを取得
    If cboPrefecture.ListIndex <> -1 Then
        selectedCode = cboPrefecture.List(cboPrefecture.ListIndex, 1)
        MsgBox "選択されたコード: " & selectedCode
    End If
End Sub

三つ目

Option Explicit

'CSVファイルを取り込むシートを初期化する
Sub InitializeSheet()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")  ' シート名を適宜変更
    
    ' シートを初期化する
    ws.Cells.ClearContents  ' セルの値をクリア
    ws.Cells.ClearFormats   ' セルの書式をクリア
    ws.Cells.ClearComments  ' セルのコメントをクリア
    ws.DrawingObjects.Delete  ' オブジェクトを削除
    
    ThisWorkbook.Save  ' 現在のファイル名で保存
End Sub

'フォーム内の要素のフォントサイズを変更する
Sub SetAllControlsFontSize(ByVal parent As Object, ByVal fontSize As Single)
    Dim ctrl As Control
    
    ' 親コントロール内のすべてのコントロールをループ
    For Each ctrl In parent.Controls
        ' フォントサイズを設定可能なコントロールの場合
        On Error Resume Next
        ctrl.Font.Size = fontSize
        On Error GoTo 0
        
        ' コントロールがContainer（フレームなど）の場合、その内部のコントロールも設定
        If TypeOf ctrl Is MSForms.Frame Or TypeOf ctrl Is MSForms.MultiPage Or TypeOf ctrl Is MSForms.TabStrip Then
            Call SetAllControlsFontSize(ctrl, fontSize)
        End If
    Next ctrl
End Sub

'元号のコレクションを返す
Function GetEraCollection()
    
    Dim eras As Collection
    Set eras = New Collection
    
    eras.Add Array("明治", "001")
    eras.Add Array("大正", "002")
    eras.Add Array("昭和", "003")
    eras.Add Array("平成", "004")
    eras.Add Array("令和", "005")
    
    Set GetEraCollection = eras
End Function

'元号のコレクションを返す
Function GetAmPmCollection()
    
    Dim ampm As Collection
    Set ampm = New Collection
    
    ampm.Add Array("午前", "001")
    ampm.Add Array("午後", "002")
    
    Set GetAmPmCollection = ampm
End Function


Sub test()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim dictTmp As Dictionary   '一次表
    Dim dictCityList As Dictionary  '都道府県コードと市区町村データの表
    Dim prefCode As String
    Dim previousPrefCode As String
    
    '都道府県の切り替わりを検出する（北海道始まり）
    previousPrefCode = "01"
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("都道府県等コード")
    
    ' リストの範囲を指定
    Set rng = ws.Range("G2:I" & ws.Cells(ws.Rows.Count, "G").End(xlUp).row)
    
    ' 一次表を作成
    Set dictTmp = New Dictionary
    
    ' 都道府県コードと市区町村データの表を作成
    Set dictCityList = New Dictionary
    dictCityList.CompareMode = vbTextCompare
    
    ' データを辞書に格納
    For Each cell In rng.Columns(1).Cells
        prefCode = Left(cell.Value, 2)
        
        If previousPrefCode = prefCode Then
            
            dictTmp.Add cell.Value, cell.Offset(0, 2).Value
            
        Else
            '次の県に進んだら、都道府県コードと当該都道府県のデータを書き込む
            
            If Not dictCityList.Exists(prefCode) Then
            
                '２桁の都道府県コードと市区町村データを書き込む
                dictCityList.Add previousPrefCode, dictTmp
                
                Set dictTmp = Nothing
                Set dictTmp = New Dictionary
                
            Else
                '
                MsgBox "都道府県コードに誤りがあります。処理を終了します。"
                Exit Sub
            End If
            '処理対象の都道府県コードを変更する。
            previousPrefCode = prefCode
        End If
        
    Next cell
    
    
                Dim debugDict As Dictionary
                Dim Key As Variant
                Dim prefCD As String
                prefCD = "35"
                
                If dictCityList.Exists(prefCD) Then
                    Debug.Print "Exist!!"
                    Debug.Print dictCityList.Count
                    
            
                    Set debugDict = dictCityList(prefCD)
                    For Each Key In debugDict.Items
                        Debug.Print Key
                    Next Key
                    debugDict.RemoveAll
                    
                Else
                    Debug.Print "NG"
                End If

    
End Sub