小さい会社の1人SEの開発記というか奮戦記

  1. 開発サンプル
  2. 223 view

課題管理表を複数プロジェクトで使える様改造

「SQL Server Express と ADO、Excel と VBA を使って課題管理表を作ってみよう」を複数プロジェクトで使えるようにプログラムを改造しましたのでそのポイントを解説します。

ダウンロード

以下のリンクでファイルをプログラム公開します。
SqlExcelKadaiKanrihyouP.zip
zipファイルの中に「SQL-Excel課題管理表P.xlsm」が入っています。

データベース

以下の2つのテーブルを使います。

プロジェクト管理用テーブル (T_プロジェクト)

CREATE TABLE [dbo].[T_プロジェクト](
	[プロジェクトID] [int] IDENTITY(1,1) NOT NULL,
	[プロジェクト名称] [nvarchar](50) NULL,
	[登録者所属] [nvarchar](50) NULL,
	[登録者氏名] [nvarchar](50) NULL,
	[登録日] [date] NULL,
	[完了予定日] [date] NULL,
	[完了日] [date] NULL,
	[削除フラグ] [nvarchar](1) NULL
)

課題管理用テーブル (T_課題管理表P)

CREATE TABLE [dbo].[T_課題管理表P](
	[ID] [int] IDENTITY(1,1) NOT NULL,
	[プロジェクトID] [int] NOT NULL,
	[No] [int] NOT NULL,
	[分類] [nvarchar](50) NULL,
	[課題] [nvarchar](max) NULL,
	[対応進捗] [nvarchar](max) NULL,
	[担当者] [nvarchar](50) NULL,
	[責任者] [nvarchar](50) NULL,
	[更新日] [date] NULL,
	[完了予定日] [date] NULL,
	[完了日] [date] NULL,
	[削除フラグ] [nvarchar](1) NULL,
	[更新時間] [datetime] NULL
)

VBAのポイントとプログラム

シートを複数使いますので定数としてワークシート名を宣言する等がポイントになります。

共通部分

Option Explicit

'   ワークシート名
Public Const TXT_WS1 As String = "プロジェクト管理"
Public Const TXT_WS2 As String = "課題管理表"

Public ADO_CN As Object                                 ' コネクションオブジェクト
Public WS1 As Worksheet                                 'シート「プロジェクト管理」
Public WS2 As Worksheet                                 'シート「課題管理表」

 
Public Sub connect() ' データベース接続
 
    '   変数宣言
    Dim TXT_CN As String                                ' 接続文
 
    '   接続文(/*** ここを環境に合わせて修正して下さい ***/)
    TXT_CN = "Provider=SQLOLEDB"                        'SQL Server
    TXT_CN = TXT_CN & "; Data Source=.\SQLEXPRESS"      '接続先の設定
    TXT_CN = TXT_CN & "; Initial Catalog=test_db"       '接続するデータベース
    TXT_CN = TXT_CN & "; User ID=test_user"             'ログインID
    TXT_CN = TXT_CN & "; Password=test_password"        'ログインパスワード
 
    '   ADOコネクションオブジェクトを作成
    Set ADO_CN = CreateObject("ADODB.Connection")
 
    '   データベース接続
    ADO_CN.Open TXT_CN
 
End Sub
 
Public Sub disconnect() ' データベース切断
    
    '   接続解除
    ADO_CN.Close
    Set ADO_CN = Nothing
 
End Sub

プロジェクト管理

プロジェクト設定

管理対象のプロジェクトIDを設定する

Sub プロジェクト対象設定()
    '   変数宣言
    Dim i1, i2, i3 As Long      'カウンタ
    Dim ADO_RS As Object        'レコードセットオブジェクト
    Dim TXT_SQ As String        'SQL文
    
    '   初期値設定
    Set WS1 = Sheets(TXT_WS1)   'ワークシート設定
    
    '   入力データチェック
    If Not IsNumeric(WS1.Cells(3, 3).Value) Then   '管理番号が数値じゃ無かったらエラー
        Call disconnect
        MsgBox "管理番号が異常です"
        Cells(3, 3).Select
        Exit Sub
    End If
    
    
    '   過去データ削除処理
    WS1.Range("C4").ClearContents
    WS1.Range("C8:C14").ClearContents

    '   データベース処理
    TXT_SQ = "SELECT * FROM T_プロジェクト WHERE (プロジェクトID=" & WS1.Cells(3, 3).Value & " And 削除フラグ = ' ');"
    Call connect                 'データベース接続
    Set ADO_RS = CreateObject("ADODB.Recordset")
    ADO_RS.Open TXT_SQ, ADO_CN

    If ADO_RS.EOF Then
        MsgBox "対象のプロジェクトIDが存在しません"
        WS1.Cells(3, 3).Select
        Call disconnect             'データベース接続解除
        Exit Sub
    Else
        WS1.Range("C4").Value = ADO_RS("プロジェクト名称")
        WS1.Range("C8").Value = ADO_RS("プロジェクト名称")
        WS1.Range("C9").Value = ADO_RS("登録者所属")
        WS1.Range("C10").Value = ADO_RS("登録者氏名")
        If IsNull(ADO_RS("登録日")) Then
            WS1.Range("C11").Value = ""
        Else
            WS1.Range("C11").Value = CDate(ADO_RS("登録日"))
        End If
        If IsNull(ADO_RS("完了予定日")) Then
            WS1.Range("C12").Value = ""
        Else
            WS1.Range("C12").Value = CDate(ADO_RS("完了予定日"))
        End If
        If IsNull(ADO_RS("完了日")) Then
            WS1.Range("C13").Value = ""
        Else
            WS1.Range("C13").Value = CDate(ADO_RS("完了日"))
        End If
    End If
        
    Call disconnect             'データベース接続解除
    MsgBox "設定が完了しました。"
    WS1.Cells(1, 1).Select
End Sub
プロジェクト一覧取得
Sub プロジェクト一覧取得()
    '   変数宣言
    Dim i1, i2, i3 As Long      'カウンタ
    Dim ADO_RS As Object        'レコードセットオブジェクト
    Dim TXT_SQ As String        'SQL文
    
    '   初期値設定
    Set WS1 = Sheets(TXT_WS1)   'ワークシート設定
    
    '   過去データ削除処理
    i2 = WS1.Cells(WS1.Cells.Rows.Count, 2).End(xlUp).Row           'B列最終行
    
    If i2 > 20 Then
        Rows("20:" & i2).Select
        Selection.Delete Shift:=xlUp                                'データ削除
    End If
    
    '   データベース処理
    TXT_SQ = "SELECT * FROM T_プロジェクト WHERE 削除フラグ = ' ' ORDER BY プロジェクトID;"
    Call connect                 'データベース接続
    Set ADO_RS = CreateObject("ADODB.Recordset")
    ADO_RS.Open TXT_SQ, ADO_CN
    
    i1 = 20
    Do Until ADO_RS.EOF
        Cells(i1, 2).Value = ADO_RS("プロジェクトID")
        Cells(i1, 3).Value = ADO_RS("プロジェクト名称")
        Cells(i1, 4).Value = ADO_RS("登録者所属")
        Cells(i1, 5).Value = ADO_RS("登録者氏名")
        If IsNull(ADO_RS("登録日")) Then
            Cells(i1, 6).Value = ""
        Else
            Cells(i1, 6).Value = CDate(ADO_RS("登録日"))
        End If
        If IsNull(ADO_RS("完了予定日")) Then
            Cells(i1, 7).Value = ""
        Else
            Cells(i1, 7).Value = CDate(ADO_RS("完了予定日"))
        End If
        If IsNull(ADO_RS("完了日")) Then
            Cells(i1, 8).Value = ""
        Else
            Cells(i1, 8).Value = CDate(ADO_RS("完了日"))
        End If
        
        i1 = i1 + 1
        ADO_RS.MoveNext
    Loop
    
    ADO_RS.Close
    Set ADO_RS = Nothing
    
    Call disconnect             'データベース接続解除
    
    MsgBox "検索が完了しました。"
    
    '   罫線を引く
    i2 = Cells(Cells.Rows.Count, 2).End(xlUp).Row   'B列最終行
    Range("B19:H" & i2).Borders.LineStyle = True
  
    '   セル折り返し処理
    Range("C20:E" & i2 + 5).Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    '   終了日<>"" でグレーアウト
    For i1 = 20 To i2
    If Cells(i1, 8).Value <> "" Then
            Range("B" & i1 & ":H" & i1).Select
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.249977111117893
                .PatternTintAndShade = 0
            End With
        End If
    Next

    WS1.Cells(1, 1).Select

End Sub
プロジェクト情報更新
Sub プロジェクト情報更新_Click()
    
    '   変数宣言
    Dim i1, i2, i3 As Long      'カウンタ
    Dim ADO_RS As Object        'レコードセットオブジェクト
    Dim TXT_SQ As String        'SQL文
    
    '   初期値設定
    Set WS1 = Sheets(TXT_WS1)   'ワークシート設定
    
    '   必須入力項目チェック
    If WS1.Cells(14, 3).Value = "" Then
        MsgBox "処理内容が指定されていません"
        WS1.Cells(14, 3).Select
        Exit Sub
    ElseIf WS1.Cells(8, 3).Value = "" Then
        MsgBox "プロジェクト名称が指定されていません"
        WS1.Cells(8, 3).Select
        Exit Sub
    ElseIf WS1.Cells(9, 3).Value = "" Then
        MsgBox "登録者所属が指定されていません"
        WS1.Cells(9, 3).Select
        Exit Sub
    ElseIf WS1.Cells(10, 3).Value = "" Then
        MsgBox "登録者氏名が指定されていません"
        WS1.Cells(10, 3).Select
        Exit Sub
    ElseIf WS1.Cells(11, 3).Value <> "" And (Not IsDate(WS1.Cells(11, 3).Value)) Then
        MsgBox "登録日が日付型として認識できません"
        WS1.Cells(11, 3).Select
        Exit Sub
    ElseIf WS1.Cells(12, 3).Value = "" Then
        MsgBox "完了予定日が指定されていません"
        WS1.Cells(12, 3).Select
        Exit Sub
    ElseIf Not IsDate(WS1.Cells(12, 3).Value) Then
        MsgBox "完了予定日が日付型として認識できません"
        WS1.Cells(12, 3).Select
        Exit Sub
    ElseIf WS1.Cells(13, 3).Value <> "" And (Not IsDate(WS1.Cells(13, 3).Value)) Then
        MsgBox "完了日が日付型として認識できません"
        WS1.Cells(13, 3).Select
        Exit Sub
    End If
    
    
    '   データ処理
    Call connect                 'データベース接続
    
    '   バッチ = 「登録」
    If WS1.Cells(14, 3).Value = "登録" Then     '処理内容が「追加」だったら処理実行
        
        '   登録日チェック
        If WS1.Cells(11, 3).Value = "" Then
            WS1.Cells(11, 3).Value = Date
        End If
        
        '   データ追加処理
        Set ADO_RS = CreateObject("ADODB.Recordset")    'ADOレコードセットオブジェクトを作成
        With ADO_RS
            .Open "T_プロジェクト", ADO_CN, adOpenDynamic, adLockOptimistic, adCmdTable
            .AddNew
                !プロジェクト名称 = WS1.Cells(8, 3).Value
                !登録者所属 = WS1.Cells(9, 3).Value
                !登録者氏名 = WS1.Cells(10, 3).Value
                !登録日 = WS1.Cells(11, 3).Value
                !完了予定日 = WS1.Cells(12, 3).Value
                !完了日 = WS1.Cells(13, 3).Value
                !削除フラグ = " "
            .Update
            .Close
        End With
        
    '   バッチ = 「更新」
    ElseIf WS1.Cells(14, 3).Value = "更新" Then
        
        If Not IsNumeric(WS1.Cells(3, 3).Value) Then   'プロジェクトIDが数値じゃ無かったらエラー
            Call disconnect
            MsgBox "プロジェクトIDが異常です"
            WS1.Cells(3, 3).Select
            Exit Sub
        End If

        TXT_SQ = "SELECT * FROM T_プロジェクト WHERE プロジェクトID = " & WS1.Cells(3, 3).Value
        Set ADO_RS = CreateObject("ADODB.Recordset")    'ADOレコードセットオブジェクトを作成
        With ADO_RS
            .Open TXT_SQ, ADO_CN, adOpenDynamic, adLockOptimistic
                !プロジェクト名称 = WS1.Cells(8, 3).Value
                !登録者所属 = WS1.Cells(9, 3).Value
                !登録者氏名 = WS1.Cells(10, 3).Value
                !登録日 = WS1.Cells(11, 3).Value
                !完了予定日 = WS1.Cells(12, 3).Value
                !完了日 = WS1.Cells(13, 3).Value
            .Update
            .Close
        End With
    
    '   バッチ = 「削除」
    ElseIf WS1.Cells(14, 3).Value = "削除" Then
        If Not IsNumeric(WS1.Cells(3, 3).Value) Then   '管理番号が数値じゃ無かったらエラー
            Call disconnect
            MsgBox "管理番号が異常です"
            Cells(3, 3).Select
            Exit Sub
        End If

        '   SQL文
        TXT_SQ = "UPDATE T_プロジェクト SET 削除フラグ = '1' WHERE (プロジェクトID = " & WS1.Cells(3, 3).Value & ");"
            
        Set ADO_RS = CreateObject("ADODB.Command")               'ADOコマンドオブジェクトを作成
        With ADO_RS
            .ActiveConnection = ADO_CN
            .CommandText = TXT_SQ
            .Execute
        End With
        
    End If
    
    Call disconnect                     'データベース接続解除
        
    '   バッチクリア
    WS1.Cells(14, 3).Value = ""
    
    MsgBox "処理が完了しました。"
    WS1.Cells(1, 1).Select
    Set WS1 = Nothing                   'ワークシートオブジェクト解放

End Sub

課題管理

  • WHERE文にプロジェクトIDを追加
  • Cellsの前にワークシートオブジェクトを追加

大筋に修正はありません。

まとめ

基本的な選択、更新、削除の処理を一通り使いましたのでかなり参考になるのではないかと思います。

エクセルの画面を見比べながらソースを見ると分かり易いと思います。

 

開発サンプルの最近記事

  1. 課題管理表を複数プロジェクトで使える様改造

  2. 「SQL Server Express と Excel を使って課題管理表を作ってみよう」…

  3. 「SQL Server Express と Excel を使って課題管理表を作ってみよう」…

  4. SQL-Excelサンプル 課題管理表最新取得ボタンを押したときの処理

  5. SQL-Excelサンプル 課題管理表全件表示ボタンを押したときの処理

関連記事

  1. 「SQL Server Express と Excel を使…

  2. SQL Server Express と Excel を使っ…

  3. SQL-Excelサンプル 課題管理表最新取得ボタンを押した…

  4. SQL-Excelサンプル 課題管理表登録ボタンを押したとき…

  5. 「SQL Server Express と Excel を使…

  6. SQL-Excelサンプル 課題管理表全件表示ボタンを押した…

コメント

  1. この記事へのコメントはありません。

  1. この記事へのトラックバックはありません。

CAPTCHA


お薦め書籍

最近の記事

  1. Access

    Accessの数値型ではまる・・・。

  2. Excel

    日本語をエンコードする【Excel VBA】

  3. Access

    クエリで日付から曜日を算出する。【Access】

  4. PCパーツ

    ASUS AMD Ryzen 4000 シリーズ搭載小型ベア…

  5. Microsoft365

    コンデジをTeamsのWebカメラに使う

  6. SQL Server

    SQL文で今日から7日前までを指定する