工具

Option Explicit

Dim currentBook As Workbook
Dim resultBook As Workbook
Dim ws As Worksheet
Dim rownum, rownum_s As Long
Dim button_flg As Integer

Function Button1_Click() As Boolean

Button1_Click = True

Dim excel As Object
Dim SheetsInNewWorkbookOrg As Long
Dim resp As Long
Dim msg As String
Set currentBook = ThisWorkbook

' If Trim(currentBook.Worksheets("パネル").Cells(2, 3).Value) = "" Then
If ((Trim(currentBook.Worksheets("パネル").Cells(2, 3).Value) = "") And _
(button_flg = 1)) Then

    resp = MsgBox(msg, vbOKCancel)
    If resp = VbMsgBoxResult.vbCancel Then
        Button1_Click = False
        Exit Function
    End If

End If
If ((Trim(currentBook.Worksheets("パネル").Cells(10, 3).Value) = "") And _
    (button_flg = 2)) Then

    resp = MsgBox(msg, vbOKCancel)
    If resp = VbMsgBoxResult.vbCancel Then
        Button1_Click = False
        Exit Function
    End If

End If

SheetsInNewWorkbookOrg = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set resultBook = Workbooks.Add

resultBook.Worksheets(1).Name = "dump"

rownum = 1
rownum_s = 2

Set ws = resultBook.Worksheets(1)

Call dbdump

If (button_flg = 1) Then
    MsgBox "Done..." + vbCrLf + vbCrLf + "      → " + resultBook.Name
    currentBook.Worksheets("パネル").Activate
Else
    resultBook.Activate
End If

End Function

Sub dbdump()

Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim dsn, uid, pwd, schema As String
Dim RCPT_NO, CUST_NO, sql As String
Dim cnt, ix, kx As Long
Dim where As String
Dim resp As Variant
Dim Global_ID As String

dsn = get_Setting("DSN")
uid = get_Setting("UID")
pwd = get_Setting("PWD")
schema = get_Setting("SCHEMA")
Global_ID = ""

' On Error GoTo err
conn.ConnectionString = "DSN=" + dsn + ";UID=" + uid + ";PWD=" + pwd + ";"
Debug.Print conn.ConnectionString
conn.Open

'引數
If (button_flg = 1) Then
    where = Trim(currentBook.Worksheets("パネル").Cells(2, 3).Value)
Else
    where = Trim(currentBook.Worksheets("パネル").Cells(10, 3).Value)
End If

ws.EnableCalculation = False
ws.Cells(1, 1).Value = "取得日時: " + Format(Now(), "yyyy/MM/dd hh:mm")
ws.Cells(1, 4).Value = "條件: 受付番號=" + where

rownum = 2

Dim i, h As Long
Dim str As String
Dim Receipt_number_flg As Boolean

'80行まで
For h = 1 To 80 Step 4
    If currentBook.Worksheets("header").Cells(h, 1) <> "" Then
        rownum = rownum + 1

        '直下３行copy
        str = Format(h, "#0") + ":" + Format(h + 3, "#0")
        currentBook.Worksheets("header").Rows(str).Copy ws.Cells(rownum, 1)
        rownum = rownum + 4
        ws.Cells(rownum, 2) = "(該當なし)"

        'SQLを作る
        sql = "select "
        Receipt_number_flg = False

        '受付番號存在判斷
        For i = 2 To 300
            If currentBook.Worksheets("header").Cells(h + 1, i) <> "" Then
                sql = sql + currentBook.Worksheets("header").Cells(h + 1, i) + ", "

                If (currentBook.Worksheets("header").Cells(h + 1, i) = "受付番號") And (i < 6) Then
                    Receipt_number_flg = True
                End If
            Else
                Exit For
            End If
        Next

        '項目羅列の終わり用のダミー
        sql = sql + "'<' "

        '受付番號存在の場合
        If (Receipt_number_flg = True) Then
            sql = "select * from " + schema + "." + currentBook.Worksheets("header").Cells(h, 1) + " where 受付番號 =" + "'" & where & "'"
        Else

        '受付番號存在しないの場合
            sql = sql + "from " + schema + "." + currentBook.Worksheets("header").Cells(h, 1) + " where コメント like " + "'" & where & "%'"
        End If

        Debug.Print sql

        'ＳＱＬ実施
        Set rs = conn.Execute(sql)

        cnt = 0
        Do Until rs.EOF
            For ix = 0 To rs.Fields.Count - 1
                ws.Rows(rownum).NumberFormatLocal = "@"
                ws.Cells(rownum, ix + 2).Value = rs.Fields(ix).Value

            Next
            cnt = cnt + 1
            rs.MoveNext
            rownum = rownum + 1
        Loop

        If cnt = 0 Then
            rownum = rownum + 1
        End If

        rs.Close

    End If
Next

err:
ws.EnableCalculation = True
On Error Resume Next
'rs.Close
conn.Close

End Sub

Function get_Setting(item As String)
Dim ix As Long
For ix = 1 To 200
If currentBook.Worksheets("setting").Cells(ix, 1).Value = item Then
get_Setting = currentBook.Worksheets("setting").Cells(ix, 2).Value
Exit Function
End If
Next

get_Setting = ""

End Function

Sub closing()

On Error Resume Next
Set currentBook = Nothing
Set ws = Nothing
Set resultBook = Nothing

End Sub