VBAの備忘録

VBAの定型をせっせと書き留める。

１．ファイルを生成し、データベースから読み出したデータを、ファイルに書き込む。しかもそのファイルが開かれているかも確認！

ファイルを生成し、データベースから読み出したデータを、ファイルに書き込む

Private Sub CommandButtonABC_Click()
    
    Dim ファイル名 As String
    Dim i As Integer
    
    '1.デスクトップにファイルを生成する------------------------------------
    'デスクトップのパスを調べる
    Dim Path As String
    Dim フルPath As String
    Dim WSH As Variant
    Set WSH = CreateObject("Wscript.Shell")
    Path = WSH.SpecialFolders("Desktop") & "\"

    MsgBox ("デスクトップにファイルを作成します。" & vbCrLf & "パス⇒" & Path)
    
    '★定義
    Dim newbk As String
     
    '★新規にブックを追加
    Workbooks.Add
    
    '★追加したブックの名前を取得
    newbk = ActiveWorkbook.Name
    
    '★アクティブにする
    Workbooks(newbk).Activate
    
    '(例)セルに入力する方法
    'Worksheets(1).Range("A1") = "新規に作成したブックです"
    'Worksheets(1).Cells(2, 3) = "ここはCells(2, 3)"
    

    '2.DBからデータを読み出し、シートに書込む----------------------------------------------

    'ヘッダー書込み
    Worksheets(1).Cells(1, 1).Value = "AAA"
    Worksheets(1).Cells(1, 2).Value = "BBB"
    Worksheets(1).Cells(1, 3).Value = "CCC"
    Worksheets(1).Cells(1, 4).Value = "DDD"
    Worksheets(1).Cells(1, 5).Value = "EEE"
    Worksheets(1).Cells(1, 6).Value = "FFF"
    Worksheets(1).Cells(1, 7).Value = "GGG"
    Worksheets(1).Cells(1, 8).Value = "HHH"
    Worksheets(1).Cells(1, 9).Value = "III"
    Worksheets(1).Cells(1, 10).Value = "JJJ"
    Worksheets(1).Cells(1, 11).Value = "KKK"
    Worksheets(1).Cells(1, 12).Value = "LLL"
    Worksheets(1).Cells(1, 13).Value = "MMM"
    
    '列の書式設定
    Worksheets(1).Columns(1).NumberFormatLocal = "@"  '文字列
    Worksheets(1).Columns(2).NumberFormatLocal = "@"  '文字列
    Worksheets(1).Columns(3).NumberFormatLocal = "@"  '文字列
    Worksheets(1).Columns(4).NumberFormatLocal = "@"  '文字列
    

    'DB接続関連の定義
    Dim SQL As String
    
    Dim cn As ADODB.Connection
    Dim cmd As ADODB.Command
    Dim rs1 As ADODB.Recordset
    
    'DBへの接続
    Set cn = New ADODB.Connection 'データ ソースへの接続
    cn.Open "接続文字列はここだよ"
    
    SQL = "select * from ○○ order by 品目コード"
    
    Set rs1 = New ADODB.Recordset
    rs1.Open SQL, cn

        If rs1.BOF = True Then  'データが無い場合の処理

        Else 'データが有る場合の処理
            i = 0
            Do
                Worksheets(1).Cells(2 + i, 1) = rs1.Fields("AAA").Value
                Worksheets(1).Cells(2 + i, 2) = rs1.Fields("BBB").Value
                Worksheets(1).Cells(2 + i, 3) = rs1.Fields("CCC").Value
                Worksheets(1).Cells(2 + i, 4) = rs1.Fields("DDD").Value
                
                If rs1.Fields("EEE").Value = 99 Then
                    Worksheets(1).Cells(2 + i, 5) = ""
                Else
                    Worksheets(1).Cells(2 + i, 5) = rs1.Fields("EEE").Value
                End If
                
                Worksheets(1).Cells(2 + i, 6) = rs1.Fields("FFF").Value
                Worksheets(1).Cells(2 + i, 7) = rs1.Fields("GGG").Value
                Worksheets(1).Cells(2 + i, 8) = rs1.Fields("HHH").Value
                Worksheets(1).Cells(2 + i, 9) = rs1.Fields("III").Value
                
                Worksheets(1).Cells(2 + i, 10) = rs1.Fields("JJJ").Value
                Worksheets(1).Cells(2 + i, 11) = rs1.Fields("KKK").Value
                Worksheets(1).Cells(2 + i, 12) = rs1.Fields("LLL").Value
                Worksheets(1).Cells(2 + i, 13) = rs1.Fields("MMM").Value
                
                rs1.MoveNext
                
                i = i + 1
            Loop Until rs1.EOF = True
        End If

    rs1.Close
    Set rs1 = Nothing

    cn.Close
    Set cn = Nothing

    '3.ファイルを保存する。----------------------------------------------------
    '列幅の指定(AutoFitするにはデータが入ってから)
    For i = 1 To 4
        Worksheets(1).Columns(i).AutoFit
    Next i
    For i = 5 To 13
        Worksheets(1).Columns(i).ColumnWidth = 9
    Next i
    
    'ファイル名の確定
    ファイル名 = "ファイル名だよ" & Format(Now, "yyyymmdd") & ".xlsx"
    
    'ファイルが開かれているかの確認
    If IsBookOpen(ファイル名) Then
        MsgBox (ファイル名 & "がひらかれているので、新規ファイルを保存できません。" & vbCrLf & "ファイルを閉じて再度ボタンをおしてください。")
        Exit Sub
    Else
        MsgBox (ファイル名 & "　を作成しました。" & vbCrLf & "新規ファイルを保存し閉じます")
    End If
    
    
    '★名前を付けて保存
    Application.DisplayAlerts = False       '---強制的に上書きするのでアラート不要
    
    フルPath = Path & ファイル名
    Workbooks(newbk).SaveAs Filename:=フルPath
    
    Application.DisplayAlerts = True        '---アラートを戻す。

    '★閉じる
    Workbooks(ファイル名).Close
    
    '★
    Set WSH = Nothing

End Sub


Function IsBookOpen(ブック名 As String) As Boolean
　'「インストラクタのネタ帳」さんより(感謝)
  Dim bk As Workbook

  IsBookOpen = False

  For Each bk In Workbooks
    If bk.Name = ブック名 Then
      IsBookOpen = True
      Exit For
    End If
  Next

End Function