TeraOmegaNetwork 2.1 「DELETE/INSERT 作成マクロ」

昔の資産を発掘したのでアップ。
使い方はマクロ読んで。
たぶん動く…

DELETE/INSERT 作成マクロ

  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
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121

Attribute VB_Name = "MakeSql"
Option Explicit

Private Type TableInfo
    ColNm As String
    IsKey As Boolean
End Type

'SQLの生成を行います。
Public Sub SubMakeSql()

    If MsgBox("実行しますか？", vbYesNo, "確認メッセージ") = vbNo Then Exit Sub

    'シートチェック
On Error GoTo Exception
    Dim sheetNm As String
    sheetNm = "Sheet1"
    Worksheets(sheetNm).Activate
    sheetNm = "Sheet2"
    Worksheets(sheetNm).Activate
    GoTo Finally
Exception:
    Call Throw(1001, "SubMakeSql", "シート名：" & sheetNm & "が存在しないため実行できません。")
Finally:

    Dim row As Long
    Dim col As Long

    Dim tblNm As String
    Dim arrCol(256) As TableInfo
    Dim colCnt As Long

    Dim outRow As Long
    outRow = 1

    Worksheets("Sheet2").Activate
    Cells.Select
    Selection.WrapText = False
    Selection.ClearContents
    Worksheets("Sheet1").Activate

    For row = 1 To 20000

        If Cells(row, 1).Value = "テーブル名" Then
            tblNm = Split(Cells(row, 2).Value, "（")(0)

            For col = 2 To 256
                arrCol(col).ColNm = Cells(row + 3, col).Value
                arrCol(col).IsKey = (Cells(row + 3, col).Font.Underline = xlUnderlineStyleSingle)
                If Cells(row + 3, col).Value = "" Then
                    colCnt = col - 1
                    Exit For
                End If
            Next
        End If

        If Cells(row, 1).Value = "INS" Then
            Dim sqlInsCol As String
            Dim sqlInsVal As String
            Dim sqlDel As String
            sqlInsCol = "INSERT INTO " & tblNm & "("

            For col = 2 To colCnt
                If col > 2 Then
                    sqlInsCol = sqlInsCol & ", "
                End If

                sqlInsCol = sqlInsCol & arrCol(col).ColNm
            Next

            sqlInsCol = sqlInsCol & ")"
            sqlInsVal = "VALUES ("
            sqlDel = ""
            Dim isFirstAnd As Boolean
            isFirstAnd = True
            For col = 2 To colCnt
                If col > 2 Then
                    sqlInsVal = sqlInsVal & ", "
                End If

                sqlInsVal = sqlInsVal & "'" & Cells(row, col).Value & "'"

                If arrCol(col).IsKey Then
                    If isFirstAnd Then
                        isFirstAnd = False
                        sqlDel = "DELETE FROM " & tblNm & " WHERE "
                    Else
                        sqlDel = sqlDel & " AND "
                    End If

                    If Cells(row, col).Value = "" Then
                        sqlDel = sqlDel & arrCol(col).ColNm & " IS NULL"
                    Else
                        sqlDel = sqlDel & arrCol(col).ColNm & " = " & "'" & Cells(row, col).Value & "'"
                    End If
                End If
            Next

            sqlInsVal = sqlInsVal & ");"

            If sqlDel <> "" Then
                sqlDel = sqlDel & ";"
            End If

            Worksheets("Sheet2").Activate
            Cells(outRow, 1).Value = sqlDel
            outRow = outRow + 1
            Cells(outRow, 1).Value = sqlInsCol
            outRow = outRow + 1
            Cells(outRow, 1).Value = sqlInsVal
            outRow = outRow + 2
            Worksheets("Sheet1").Activate
        End If
    Next
    Worksheets("Sheet2").Activate
    Range("A1").Select

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

Attribute VB_Name = "SubMenu"
Option Explicit

'
'参考ＵＲＬ：http://www.aa.alpha-net.ne.jp/pcfriend/Excel/MenuBar.htm
'

Dim mySubMenu As CommandBarControl 'マイサブメニュー

'マイサブメニューの作成
Sub MakeSubMenu()
'メニューバーにコマンドボタンを作成する
Dim myMenu As CommandBar
Dim cmdSubMenu As CommandBarControl
    'すでにサブメニューがあれば削除する
    DelSubMenu

    'メニューバーに「ゆーてぃりてぃー」サブメニューを配置する
    Set myMenu = Application.CommandBars("worksheet Menu Bar")
    Set mySubMenu = myMenu.Controls.Add(Type:=msoControlPopup)
    mySubMenu.Caption = "ゆーてぃりてぃー"

    '「ゆーてぃりてぃー」サブメニューに「SQL生成」を作成
    Set cmdSubMenu = mySubMenu.Controls.Add(Type:=msoControlButton)
    cmdSubMenu.Caption = "SQL生成"
    'サブメニューでコマンド1を選択したとき cmd1() を呼び出す
    cmdSubMenu.OnAction = "BtnMakeSql"

End Sub

'マイサブメニューを削除する
Sub DelSubMenu()
'メニューバーのサブメニューを削除する
    On Error Resume Next
    mySubMenu.Delete
End Sub

'「メニュー＞ゆーてぃりてぃー＞ SQL生成」イベント
Private Sub BtnMakeSql()
    Call SetOffscreenStart
On Error GoTo Catch
    Call SubMakeSql
    GoTo Finally

Catch:
    MsgBox Err.Description, vbCritical, "エラーメッセージ"
    GoTo Finally

Finally:
    Call SetOffscreenStop
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

Attribute VB_Name = "Util"
'再計算および再描画を無効にする
Public Sub SetOffscreenStart()
    Application.Cursor = xlWait
    Application.StatusBar = "処理中..."
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
End Sub

'再計算および再描画の無効を止める
Public Sub SetOffscreenStop()
    Application.Cursor = xlDefault
    Application.StatusBar = ""
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

'Errが存在する場合Trueを返却します。
Function IsException() As Boolean
    IsException = Err.Number <> 0
End Function

'現在保持されているErrを投げます。
Sub DefaultThrow()
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub

'パラメータを元にErrを投げます。
Sub Throw(ByVal errNumber As Integer, ByVal errSource As String, ByVal errDescription As String)
    Err.Raise errNumber, errSource, errDescription
End Sub