Excel VBAで取得するテーブルデータを主キーの昇順にソートしてみた

これまで、Excel VBAでOracleに接続し、指定したSELECT文のデータを繰り返し取得するプログラムを作成していたが、今回はそのプログラムを修正し、SELECT文にorder by句が含まれていない場合は、主キーの昇順にソートするようにしてみたので、そのサンプルプログラムを共有する。

前提条件

下記記事のサンプルプログラムの作成が完了していること。

Excel VBAで複数テーブルのデータを繰り返し取得するプログラムを作成してみた(ソースコード編)今回も引き続き、複数のテーブルデータを繰り返し取得する処理のサンプルプログラムについて述べる。ここでは、具体的なサンプルプログラムのソー...

また、user_dataテーブルのデータが以下のように、主キーの昇順にソートした場合とソートしない場合で結果が異なっていること。

サンプルプログラムの作成

修正した「取得」ボタンが押下された場合に呼び出されるプログラム「dbDump」サブプロシージャの内容は以下の通りで、今回追加した「getPrimaryKey」関数で主キー情報を取得し、SQLを生成する「getSQL」関数で、SELECT文にorder by句が含まれていない場合は主キーの昇順にソートするように修正している。

Option Explicit  '変数の宣言を必須にする

'-----------------------------------------------------------
' 機能: DBダンプを取得する
' 引数: なし
' 返り値: なし
'-----------------------------------------------------------
Sub dbDump()
    '変数宣言
    Dim ADOConnection As ADODB.Connection
    Dim sSQL As String
    Dim lnSqlIdx As Long
    Dim sWorkSheetName As String
    Dim lnLstRow As Long
    Dim blSqlResult As Boolean
    Dim primaryKeyList As Object
    
    '定数宣言
    Const sqlRowNum = 10
    
    '入力チェックを行う
    If chkInput() = False Then
        Exit Sub
    End If
    
    'DBに接続
    Set ADOConnection = connectDB()
    
    'DBに接続できなければ、処理を終了
    If ADOConnection Is Nothing Then
        Exit Sub
    End If
    
    '実行SQLに書かれた行数分繰り返す
    For lnSqlIdx = 1 To sqlRowNum
    
        '主キー情報を取得
        Set primaryKeyList = getPrimaryKey(lnSqlIdx, ADOConnection)
    
        '実行SQL文を生成
        sSQL = getSQL(lnSqlIdx, primaryKeyList)
        
        '実行SQLが生成できた場合は、SQLの実行結果を記載
        If sSQL <> "" Then
        
            'ワークシート名を取得し、無ければ追加
            sWorkSheetName = Worksheets("実行情報").Cells(lnSqlIdx + 11, 4).Value
            Call addWorkSheet(sWorkSheetName)
            
            '指定したワークシートの最終行を取得
            lnLstRow = getLastRow(sWorkSheetName)
        
            'SQL実行結果を記載
            blSqlResult = writeSqlResult(sSQL, _
                sWorkSheetName, lnLstRow + 2, ADOConnection)
            
            'エラーが発生した場合は、処理を終了
            If blSqlResult = False Then
                Exit For
            End If
        End If
        
    Next
        
    'DBから切断
    Call disConnectDB(ADOConnection)
        
    'SQL実行結果記載処理でエラーがなければ、実行情報シートを
    'アクティブにし、完了メッセージを表示
    If blSqlResult = True Then
        Worksheets("実行情報").Activate
        MsgBox "DBダンプ取得処理が完了しました"
    End If

End Sub

'-----------------------------------------------------------
' 機能: 「実行情報」シートの入力チェック処理を行う
' 引数: なし
' 返り値: 処理結果(True:エラー無、False:エラー有)
'-----------------------------------------------------------
Function chkInput() As Boolean
    'SIDが未入力の場合はエラー
    If Worksheets("実行情報").Cells(5, 3).Value = "" Then
        MsgBox "SIDを入力してください"
        chkInput = False
        Worksheets("実行情報").Cells(5, 3).Select
        Exit Function
    End If
    
    'ユーザーIDが未入力の場合はエラー
    If Worksheets("実行情報").Cells(6, 3).Value = "" Then
        MsgBox "ユーザーIDを入力してください"
        chkInput = False
        Worksheets("実行情報").Cells(6, 3).Select
        Exit Function
    End If
    
    'パスワードが未入力の場合はエラー
    If Worksheets("実行情報").Cells(7, 3).Value = "" Then
        MsgBox "パスワードを入力してください"
        chkInput = False
        Worksheets("実行情報").Cells(7, 3).Select
        Exit Function
    End If

    '取得タイミングが未入力の場合はエラー
    If Worksheets("実行情報").Cells(5, 7).Value = "" Then
        MsgBox "取得タイミングを入力してください"
        chkInput = False
        Worksheets("実行情報").Cells(5, 7).Select
        Exit Function
    End If
    
    'テーブル名が全て空白の場合はエラー
    Dim rng As Range
    Set rng = Range("D12", "D21")
    If WorksheetFunction.CountA(rng) = 0 Then
        MsgBox "テーブル名が全て未入力です"
        chkInput = False
        Worksheets("実行情報").Cells(12, 4).Select
        Exit Function
    End If
    
    'テーブル名が空白以外で重複がある場合はエラー
    Dim lnTblName As Long
    For lnTblName = 12 To 21
        If Cells(lnTblName, 4) <> "" _
            And WorksheetFunction.CountIf(Worksheets("実行情報").Range("D12:D21"), _
                Worksheets("実行情報").Cells(lnTblName, 4)) > 1 Then
                    MsgBox "テーブル名 " & Worksheets("実行情報").Cells(lnTblName, 4) _
                        & " が重複しています"
                    chkInput = False
                    Worksheets("実行情報").Cells(lnTblName, 4).Select
                    Exit Function
        End If
    Next
    
    chkInput = True
    
End Function

'-----------------------------------------------------------
' 機能: DB接続を行う
' 引数: なし
' 返り値: DB接続コネクション
'-----------------------------------------------------------
Function connectDB() As ADODB.Connection
   '変数定義
   Dim sId As String
   Dim sUser As String
   Dim sPass As String
   Dim ADOConnection As ADODB.Connection
   
   'DB接続情報
   sId = Worksheets("実行情報").Cells(5, 3).Value     'SID
   sUser = Worksheets("実行情報").Cells(6, 3).Value   'ユーザーID
   sPass = Worksheets("実行情報").Cells(7, 3).Value   'パスワード
   
   'DB接続
   On Error GoTo ErrOpenDb
   Set ADOConnection = New ADODB.Connection
   ADOConnection.ConnectionString = "Provider=OraOLEDB.Oracle;Data Source=" _
                   & sId & ";User ID=" & sUser & ";Password=" & sPass & ";"
   ADOConnection.Open
   
   Set connectDB = ADOConnection
   
   Exit Function
   
ErrOpenDb:
   'エラー時は、エラーメッセージを表示
   MsgBox "エラーが発生しました" _
               & vbCrLf & vbCrLf & Err.Description
               
   Set connectDB = Nothing
   
End Function

'-------------------------------------------------------------------
' 機能:　　 主キー情報を取得する
' 引数:     sqlIdx        : 実行SQLの指定された行
'           ADOConnection : DB接続コネクション
' 返り値:   主キー情報
'-------------------------------------------------------------------
Private Function getPrimaryKey(ByVal sqlIdx As Long, _
                               ADOConnection As ADODB.Connection) As Object

   '変数定義
   Dim ADORecordset As New ADODB.Recordset
   Dim sTblName As String
   Dim tmpPriList As Object  '主キー格納用一時リスト
   Dim priList As Object     '主キー格納用リスト
   Dim elem As Variant
   
   'テーブル名を取得し、テーブル名が空文字の場合は空文字を返す
   sTblName = Worksheets("実行情報").Cells(11 + sqlIdx, 4).Value
   If sTblName = "" Then
       Set getPrimaryKey = Nothing
       Exit Function
   End If
   
   'リストを生成
   Set tmpPriList = CreateObject("System.Collections.ArrayList")
   Set priList = CreateObject("System.Collections.ArrayList")
   
   '主キー情報を取得するためのADORecordsetを生成
   Set ADORecordset = ADOConnection.OpenSchema(adSchemaPrimaryKeys)

   '主キー情報をリストに格納し、複合キーの順に並び替える
   Do Until ADORecordset.EOF
       If ADORecordset("TABLE_NAME").Value = UCase(sTblName) Then
          tmpPriList.Add (ADORecordset("ORDINAL").Value & "," _
              & ADORecordset("COLUMN_NAME").Value)
          Exit Do
       End If
       ADORecordset.MoveNext
   Loop
   tmpPriList.Sort
   
   '返却用主キー情報を設定する
   For Each elem In tmpPriList
      priList.Add (Right(elem, Len(elem) - InStr(elem, ",")))
   Next
   Set tmpPriList = Nothing
   
   'ADORecordsetを閉じる
   ADORecordset.Close
   Set ADORecordset = Nothing

   Set getPrimaryKey = priList
   Set priList = Nothing
   
End Function

'---------------------------------------------------------------
' 機能: 実行情報シートの実行SQLで指定された行のSQL文を生成する
' 引数: sqlIdx : 実行SQLのインデックス
'       primaryKeyList: 主キーリスト
' 返り値: 生成されたSQL文
'---------------------------------------------------------------
Function getSQL(sqlIdx As Long, primaryKeyList As Object) As String
    '変数定義
    Dim sTblName As String
    Dim sWhere As String
    Dim elem As Variant
    
    'テーブル名とWhere句を取得
    sTblName = Worksheets("実行情報").Cells(sqlIdx + 11, 4).Value
    sWhere = Worksheets("実行情報").Cells(sqlIdx + 11, 6).Value
    
    'テーブル名が空文字の場合は空文字を返す
    If sTblName = "" Then
        getSQL = ""
        Exit Function
    End If
    
    'SELECT文を生成
    getSQL = "select * from " & sTblName
    If sWhere <> "" Then
        getSQL = getSQL & " where " & sWhere
    End If
    
    'SELECT文に、order by句が含まれていない場合は、主キー情報によるorder by句を追記
    If InStr(Replace(Replace(UCase(getSQL), "　", ""), " ", ""), "ORDERBY") = 0 _
            And primaryKeyList.Count > 0 Then
        getSQL = getSQL & " order by "
        For Each elem In primaryKeyList
            getSQL = getSQL & elem
            getSQL = getSQL & ", "
        Next
        getSQL = Left(getSQL, Len(getSQL) - Len(", "))
        getSQL = getSQL & " asc"
    End If
    
End Function

'----------------------------------------------------------------------
' 機能: 指定されたシート名のワークシートが無ければ追加する
' 引数: sWorkSheetName : シート名
' 返り値: なし
'----------------------------------------------------------------------
Sub addWorkSheet(sWorkSheetName As String)
    '変数定義
    Dim ws As Worksheet
    
    '指定したシートが存在するかどうかチェックし、存在しない場合のみ追加する
    For Each ws In Sheets
        If ws.Name = sWorkSheetName Then
           Exit Sub
        End If
    Next
    Worksheets().Add After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = sWorkSheetName
    ActiveSheet.Cells.Select
    Selection.NumberFormatLocal = "@"  '書式は文字列を指定
    Range("A1").Select
    
End Sub

'----------------------------------------------------------------------
' 機能: 指定されたシート名のワークシートを削除する
' 引数: sWorkSheetName : シート名
' 返り値: なし
'----------------------------------------------------------------------
Sub deleteWorkSheet(sWorkSheetName As String)
    '変数定義
    Dim ws As Worksheet
    Dim lnDelOk As Long
    
    '指定したシートが存在するかどうかチェック
    '指定したシートが存在する場合は、確認ダイアログで確認後削除
    For Each ws In Sheets
        If ws.Name = sWorkSheetName Then
           Application.DisplayAlerts = False
           lnDelOk = MsgBox("ワークシート「" & sWorkSheetName _
                              & "」を削除します。よろしいでしょうか？", vbYesNo)
           If lnDelOk = vbYes Then
              Worksheets(sWorkSheetName).Delete
           End If
           Application.DisplayAlerts = True
           Exit For
        End If
    Next
    
End Sub

'------------------------------------------------------------------
' 機能: 指定されたシートが何行目まで使用されているかを取得する
'       その際、3行以上空白行が続く直前の行数を取得する
' 引数: sWorkSheetName : シート名
' 返り値: 最終行
'------------------------------------------------------------------
Function getLastRow(sWorkSheetName As String) As Long
   '変数定義
   Dim lnLstRow As Long
   
   '3行以上空白が続く直前の行数を取得
   If Worksheets(sWorkSheetName).Cells(1, 1) = "" _
      And Worksheets(sWorkSheetName).Cells(2, 1) = "" _
      And Worksheets(sWorkSheetName).Cells(3, 1) = "" Then
      getLastRow = 0
   Else
      lnLstRow = 1
      Do Until Worksheets(sWorkSheetName).Cells(lnLstRow, 1) = "" _
        And Worksheets(sWorkSheetName).Cells(lnLstRow + 1, 1) = "" _
        And Worksheets(sWorkSheetName).Cells(lnLstRow + 2, 1) = ""
          lnLstRow = lnLstRow + 1
      Loop
      getLastRow = lnLstRow - 1
   End If
   
End Function

'------------------------------------------------------------------
' 機能: 引数で指定したSQL文の実行結果を出力する
' 引数: sSQL           : 実行するSQL行
'       sWorkSheetName : ワークシート名
'       lnFstRow       : 記載開始行
'       ADOConnection  : DB接続コネクション
' 返り値: 処理結果(True:エラー無、False:エラー有)
'------------------------------------------------------------------
Function writeSqlResult(sSQL As String, sWorkSheetName As String _
                 , lnFstRow As Long, ADOConnection As ADODB.Connection)
   '変数定義
   Dim sEvent As String
   Dim sInstance As String
   Dim sUser As String
   Dim sPassword As String
   Dim ADORecordset As New ADODB.Recordset
   Dim myRS As New ADODB.Recordset
   
   Dim inFldCnt As Integer
   Dim lnRowCnt As Long
   Dim i As Long
   
   'SQLの実行
   On Error GoTo ErrExecSelect
   ADORecordset.Open sSQL, ADOConnection
   
   'アクティブシートをテーブル名のシートに設定
   Worksheets(sWorkSheetName).Activate
   
   '実行タイミングをワークシートに追記し、セル結合
   sEvent = Worksheets("実行情報").Cells(5, 7).Value
   Cells(lnFstRow, 1) = "【取得タイミング】" & sEvent
   Range(Cells(lnFstRow, 1), Cells(lnFstRow, 10)).Merge
   
   'SQL文をワークシートに追記し、セル結合
   Cells(lnFstRow + 1, 1) = "SQL: " & sSQL
   Range(Cells(lnFstRow + 1, 1), Cells(lnFstRow + 1, 10)).Merge
   
   'カラム数を取得
   inFldCnt = ADORecordset.Fields.Count
   
   'カラム名を先頭に表示
   For i = 1 To inFldCnt
      Cells(lnFstRow + 2, i).Value = ADORecordset.Fields(i - 1).Name
      Cells(lnFstRow + 2, i).Interior.Color = RGB(0, 32, 96)
      Cells(lnFstRow + 2, i).Font.Color = RGB(255, 255, 255)
   Next
   
   '先頭レコードからEOFまで繰り返し追記
   lnRowCnt = lnFstRow + 3
   Do Until ADORecordset.EOF
       For i = 1 To inFldCnt
          'カラム値を順に表示
          Cells(lnRowCnt, i) = ADORecordset.Fields(i - 1).Value
          Cells(lnRowCnt, i).Interior.Color = RGB(221, 235, 247)
       Next
       ADORecordset.MoveNext
       lnRowCnt = lnRowCnt + 1
   Loop
      
   'ADORecordsetを閉じる
   ADORecordset.Close
   Set ADORecordset = Nothing
   
   '列幅を自動調整する
   Range(Columns(1), Columns(inFldCnt)).EntireColumn.AutoFit
   Range(Columns(11), Columns(14)).EntireColumn.AutoFit
   
   writeSqlResult = True
   Exit Function
   
ErrExecSelect:
   'エラー時は、エラーメッセージを表示
   MsgBox "エラーが発生しました" _
               & vbCrLf & vbCrLf & Err.Description _
               & vbCrLf & vbCrLf & " 実行SQL：" & sSQL
               
   '指定したシートを削除
   Call deleteWorkSheet(sWorkSheetName)
   writeSqlResult = False
   
End Function

'-----------------------------------------------------------
' 機能: DB切断を行う
' 引数: ADOConnection : DB接続コネクション
' 返り値: なし
'-----------------------------------------------------------
Sub disConnectDB(ADOConnection As ADODB.Connection)
   'DB切断
   If Not (ADOConnection Is Nothing) Then
       ADOConnection.Close
       Set ADOConnection = Nothing
   End If
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

408

409

410

411

412

413

414

415

416

417

418

419

420

421

422

423

424

425

426

427

428

429

430

431

432

433

434

435

436

437

438

439

440

441

442

443

444

445

446

447

448

449

Option Explicit '変数の宣言を必須にする

'-----------------------------------------------------------

' 機能: DBダンプを取得する

' 引数: なし

' 返り値: なし

'-----------------------------------------------------------

Sub dbDump()

'変数宣言

Dim ADOConnection As ADODB.Connection

Dim sSQL As String

Dim lnSqlIdx As Long

Dim sWorkSheetName As String

Dim lnLstRow As Long

Dim blSqlResult As Boolean

Dim primaryKeyList As Object

'定数宣言

Const sqlRowNum = 10

'入力チェックを行う

If chkInput() = False Then

Exit Sub

End If

'DBに接続

Set ADOConnection = connectDB()

'DBに接続できなければ、処理を終了

If ADOConnection Is Nothing Then

Exit Sub

End If

'実行SQLに書かれた行数分繰り返す

For lnSqlIdx = 1 To sqlRowNum

'主キー情報を取得

Set primaryKeyList = getPrimaryKey(lnSqlIdx, ADOConnection)

'実行SQL文を生成

sSQL = getSQL(lnSqlIdx, primaryKeyList)

'実行SQLが生成できた場合は、SQLの実行結果を記載

If sSQL <> "" Then

'ワークシート名を取得し、無ければ追加

sWorkSheetName = Worksheets("実行情報").Cells(lnSqlIdx + 11, 4).Value

Call addWorkSheet(sWorkSheetName)

'指定したワークシートの最終行を取得

lnLstRow = getLastRow(sWorkSheetName)

'SQL実行結果を記載

blSqlResult = writeSqlResult(sSQL, _

sWorkSheetName, lnLstRow + 2, ADOConnection)

'エラーが発生した場合は、処理を終了

If blSqlResult = False Then

Exit For

End If

'DBから切断

Call disConnectDB(ADOConnection)

'SQL実行結果記載処理でエラーがなければ、実行情報シートを

'アクティブにし、完了メッセージを表示

If blSqlResult = True Then

Worksheets("実行情報").Activate

MsgBox "DBダンプ取得処理が完了しました"

End If

End Sub

'-----------------------------------------------------------

' 機能: 「実行情報」シートの入力チェック処理を行う

' 引数: なし

' 返り値: 処理結果(True:エラー無、False:エラー有)

'-----------------------------------------------------------

Function chkInput() As Boolean

'SIDが未入力の場合はエラー

If Worksheets("実行情報").Cells(5, 3).Value = "" Then

MsgBox "SIDを入力してください"

chkInput = False

Worksheets("実行情報").Cells(5, 3).Select

Exit Function

End If

'ユーザーIDが未入力の場合はエラー

If Worksheets("実行情報").Cells(6, 3).Value = "" Then

MsgBox "ユーザーIDを入力してください"

chkInput = False

Worksheets("実行情報").Cells(6, 3).Select

Exit Function

End If

'パスワードが未入力の場合はエラー

If Worksheets("実行情報").Cells(7, 3).Value = "" Then

MsgBox "パスワードを入力してください"

chkInput = False

Worksheets("実行情報").Cells(7, 3).Select

Exit Function

End If

'取得タイミングが未入力の場合はエラー

If Worksheets("実行情報").Cells(5, 7).Value = "" Then

MsgBox "取得タイミングを入力してください"

chkInput = False

Worksheets("実行情報").Cells(5, 7).Select

Exit Function

End If

'テーブル名が全て空白の場合はエラー

Dim rng As Range

Set rng = Range("D12", "D21")

If WorksheetFunction.CountA(rng) = 0 Then

MsgBox "テーブル名が全て未入力です"

chkInput = False

Worksheets("実行情報").Cells(12, 4).Select

Exit Function

End If

'テーブル名が空白以外で重複がある場合はエラー

Dim lnTblName As Long

For lnTblName = 12 To 21

If Cells(lnTblName, 4) <> "" _

And WorksheetFunction.CountIf(Worksheets("実行情報").Range("D12:D21"), _

Worksheets("実行情報").Cells(lnTblName, 4)) > 1 Then

MsgBox "テーブル名 " & Worksheets("実行情報").Cells(lnTblName, 4) _

& " が重複しています"

chkInput = False

Worksheets("実行情報").Cells(lnTblName, 4).Select

Exit Function

End If

chkInput = True

End Function

'-----------------------------------------------------------

' 機能: DB接続を行う

' 引数: なし

' 返り値: DB接続コネクション

'-----------------------------------------------------------

Function connectDB() As ADODB.Connection

'変数定義

Dim sId As String

Dim sUser As String

Dim sPass As String

Dim ADOConnection As ADODB.Connection

'DB接続情報

sId = Worksheets("実行情報").Cells(5, 3).Value 'SID

sUser = Worksheets("実行情報").Cells(6, 3).Value 'ユーザーID

sPass = Worksheets("実行情報").Cells(7, 3).Value 'パスワード

'DB接続

On Error GoTo ErrOpenDb

Set ADOConnection = New ADODB.Connection

ADOConnection.ConnectionString = "Provider=OraOLEDB.Oracle;Data Source=" _

& sId & ";User ID=" & sUser & ";Password=" & sPass & ";"

ADOConnection.Open

Set connectDB = ADOConnection

Exit Function

ErrOpenDb:

'エラー時は、エラーメッセージを表示

MsgBox "エラーが発生しました" _

& vbCrLf & vbCrLf & Err.Description

Set connectDB = Nothing

End Function

'-------------------------------------------------------------------

' 機能:　　主キー情報を取得する

' 引数: sqlIdx : 実行SQLの指定された行

' ADOConnection : DB接続コネクション

' 返り値: 主キー情報

'-------------------------------------------------------------------

Private Function getPrimaryKey(ByVal sqlIdx As Long, _

ADOConnection As ADODB.Connection) As Object

'変数定義

Dim ADORecordset As New ADODB.Recordset

Dim sTblName As String

Dim tmpPriList As Object '主キー格納用一時リスト

Dim priList As Object '主キー格納用リスト

Dim elem As Variant

'テーブル名を取得し、テーブル名が空文字の場合は空文字を返す

sTblName = Worksheets("実行情報").Cells(11 + sqlIdx, 4).Value

If sTblName = "" Then

Set getPrimaryKey = Nothing

Exit Function

End If

'リストを生成

Set tmpPriList = CreateObject("System.Collections.ArrayList")

Set priList = CreateObject("System.Collections.ArrayList")

'主キー情報を取得するためのADORecordsetを生成

Set ADORecordset = ADOConnection.OpenSchema(adSchemaPrimaryKeys)

'主キー情報をリストに格納し、複合キーの順に並び替える

Do Until ADORecordset.EOF

If ADORecordset("TABLE_NAME").Value = UCase(sTblName) Then

tmpPriList.Add (ADORecordset("ORDINAL").Value & "," _

& ADORecordset("COLUMN_NAME").Value)

Exit Do

End If

ADORecordset.MoveNext

Loop

tmpPriList.Sort

'返却用主キー情報を設定する

For Each elem In tmpPriList

priList.Add (Right(elem, Len(elem) - InStr(elem, ",")))

Set tmpPriList = Nothing

'ADORecordsetを閉じる

ADORecordset.Close

Set ADORecordset = Nothing

Set getPrimaryKey = priList

Set priList = Nothing

End Function

'---------------------------------------------------------------

' 機能: 実行情報シートの実行SQLで指定された行のSQL文を生成する

' 引数: sqlIdx : 実行SQLのインデックス

' primaryKeyList: 主キーリスト

' 返り値: 生成されたSQL文

'---------------------------------------------------------------

Function getSQL(sqlIdx As Long, primaryKeyList As Object) As String

'変数定義

Dim sTblName As String

Dim sWhere As String

Dim elem As Variant

'テーブル名とWhere句を取得

sTblName = Worksheets("実行情報").Cells(sqlIdx + 11, 4).Value

sWhere = Worksheets("実行情報").Cells(sqlIdx + 11, 6).Value

'テーブル名が空文字の場合は空文字を返す

If sTblName = "" Then

getSQL = ""

Exit Function

End If

'SELECT文を生成

getSQL = "select * from " & sTblName

If sWhere <> "" Then

getSQL = getSQL & " where " & sWhere

End If

'SELECT文に、order by句が含まれていない場合は、主キー情報によるorder by句を追記

If InStr(Replace(Replace(UCase(getSQL), "　", ""), " ", ""), "ORDERBY") = 0 _

And primaryKeyList.Count > 0 Then

getSQL = getSQL & " order by "

For Each elem In primaryKeyList

getSQL = getSQL & elem

getSQL = getSQL & ", "

getSQL = Left(getSQL, Len(getSQL) - Len(", "))

getSQL = getSQL & " asc"

End If

End Function

'----------------------------------------------------------------------

' 機能: 指定されたシート名のワークシートが無ければ追加する

' 引数: sWorkSheetName : シート名

' 返り値: なし

'----------------------------------------------------------------------

Sub addWorkSheet(sWorkSheetName As String)

'変数定義

Dim ws As Worksheet

'指定したシートが存在するかどうかチェックし、存在しない場合のみ追加する

For Each ws In Sheets

If ws.Name = sWorkSheetName Then

Exit Sub

End If

Worksheets().Add After:=Worksheets(Worksheets.Count)

ActiveSheet.Name = sWorkSheetName

ActiveSheet.Cells.Select

Selection.NumberFormatLocal = "@" '書式は文字列を指定

Range("A1").Select

End Sub

'----------------------------------------------------------------------

' 機能: 指定されたシート名のワークシートを削除する

' 引数: sWorkSheetName : シート名

' 返り値: なし

'----------------------------------------------------------------------

Sub deleteWorkSheet(sWorkSheetName As String)

'変数定義

Dim ws As Worksheet

Dim lnDelOk As Long

'指定したシートが存在するかどうかチェック

'指定したシートが存在する場合は、確認ダイアログで確認後削除

For Each ws In Sheets

If ws.Name = sWorkSheetName Then

Application.DisplayAlerts = False

lnDelOk = MsgBox("ワークシート「" & sWorkSheetName _

& "」を削除します。よろしいでしょうか？", vbYesNo)

If lnDelOk = vbYes Then

Worksheets(sWorkSheetName).Delete

End If

Application.DisplayAlerts = True

Exit For

End If

End Sub

'------------------------------------------------------------------

' 機能: 指定されたシートが何行目まで使用されているかを取得する

' その際、3行以上空白行が続く直前の行数を取得する

' 引数: sWorkSheetName : シート名

' 返り値: 最終行

'------------------------------------------------------------------

Function getLastRow(sWorkSheetName As String) As Long

'変数定義

Dim lnLstRow As Long

'3行以上空白が続く直前の行数を取得

If Worksheets(sWorkSheetName).Cells(1, 1) = "" _

And Worksheets(sWorkSheetName).Cells(2, 1) = "" _

And Worksheets(sWorkSheetName).Cells(3, 1) = "" Then

getLastRow = 0

Else

lnLstRow = 1

Do Until Worksheets(sWorkSheetName).Cells(lnLstRow, 1) = "" _

And Worksheets(sWorkSheetName).Cells(lnLstRow + 1, 1) = "" _

And Worksheets(sWorkSheetName).Cells(lnLstRow + 2, 1) = ""

lnLstRow = lnLstRow + 1

Loop

getLastRow = lnLstRow - 1

End If

End Function

'------------------------------------------------------------------

' 機能: 引数で指定したSQL文の実行結果を出力する

' 引数: sSQL : 実行するSQL行

' sWorkSheetName : ワークシート名

' lnFstRow : 記載開始行

' ADOConnection : DB接続コネクション

' 返り値: 処理結果(True:エラー無、False:エラー有)

'------------------------------------------------------------------

Function writeSqlResult(sSQL As String, sWorkSheetName As String _

, lnFstRow As Long, ADOConnection As ADODB.Connection)

'変数定義

Dim sEvent As String

Dim sInstance As String

Dim sUser As String

Dim sPassword As String

Dim ADORecordset As New ADODB.Recordset

Dim myRS As New ADODB.Recordset

Dim inFldCnt As Integer

Dim lnRowCnt As Long

Dim i As Long

'SQLの実行

On Error GoTo ErrExecSelect

ADORecordset.Open sSQL, ADOConnection

'アクティブシートをテーブル名のシートに設定

Worksheets(sWorkSheetName).Activate

'実行タイミングをワークシートに追記し、セル結合

sEvent = Worksheets("実行情報").Cells(5, 7).Value

Cells(lnFstRow, 1) = "【取得タイミング】" & sEvent

Range(Cells(lnFstRow, 1), Cells(lnFstRow, 10)).Merge

'SQL文をワークシートに追記し、セル結合

Cells(lnFstRow + 1, 1) = "SQL: " & sSQL

Range(Cells(lnFstRow + 1, 1), Cells(lnFstRow + 1, 10)).Merge

'カラム数を取得

inFldCnt = ADORecordset.Fields.Count

'カラム名を先頭に表示

For i = 1 To inFldCnt

Cells(lnFstRow + 2, i).Value = ADORecordset.Fields(i - 1).Name

Cells(lnFstRow + 2, i).Interior.Color = RGB(0, 32, 96)

Cells(lnFstRow + 2, i).Font.Color = RGB(255, 255, 255)

'先頭レコードからEOFまで繰り返し追記

lnRowCnt = lnFstRow + 3

Do Until ADORecordset.EOF

For i = 1 To inFldCnt

'カラム値を順に表示

Cells(lnRowCnt, i) = ADORecordset.Fields(i - 1).Value

Cells(lnRowCnt, i).Interior.Color = RGB(221, 235, 247)

ADORecordset.MoveNext

lnRowCnt = lnRowCnt + 1

Loop

'ADORecordsetを閉じる

ADORecordset.Close

Set ADORecordset = Nothing

'列幅を自動調整する

Range(Columns(1), Columns(inFldCnt)).EntireColumn.AutoFit

Range(Columns(11), Columns(14)).EntireColumn.AutoFit

writeSqlResult = True

Exit Function

ErrExecSelect:

'エラー時は、エラーメッセージを表示

MsgBox "エラーが発生しました" _

& vbCrLf & vbCrLf & Err.Description _

& vbCrLf & vbCrLf & " 実行SQL：" & sSQL

'指定したシートを削除

Call deleteWorkSheet(sWorkSheetName)

writeSqlResult = False

End Function

'-----------------------------------------------------------

' 機能: DB切断を行う

' 引数: ADOConnection : DB接続コネクション

' 返り値: なし

'-----------------------------------------------------------

Sub disConnectDB(ADOConnection As ADODB.Connection)

'DB切断

If Not (ADOConnection Is Nothing) Then

ADOConnection.Close

Set ADOConnection = Nothing

End If

End Sub

その他、実際に作成したVBAファイルの内容は、以下のサイトを参照のこと。
https://github.com/purin-it/vba/tree/master/excel-vba-oracle-orderby-pkey

サンプルプログラムの実行結果

今回作成したサンプルプログラムの実行結果は、以下の通り。

1) サンプルプログラム「DbDump.xlsm」を開き、下記のように値を入力し「取得」ボタンを押下する。

2) 以下のように完了メッセージが表示されるので、「OK」ボタンを押下

3) 「user_data」シートを確認すると、IDの昇順にデータが出力されることが確認できる。

4) 今回修正前のサンプルプログラムで同じ処理を実行すると、データの取得結果がIDの昇順でないことが確認できる。

要点まとめ

主キー情報は、ADOConnectionオブジェクトのOpenSchemaメソッドで、引数adSchemaPrimaryKeysを指定することで、そのレコードセットが取得できる。

前提条件

サンプルプログラムの作成

サンプルプログラムの実行結果

要点まとめ

Excel VBAでOracle接続し取得したテーブルデータを1シートにまとめて出力してみた

Excel VBAでOracle接続するプログラムを作成する準備をしてみた

Excel VBAのマクロ記録を利用してみた

Excel VBAを利用してみた

Excel VBAで複数テーブルのデータを繰り返し取得するプログラムを作成してみた(完成イメージ編)

Excel VBAでボタンが押下されたときのイベント処理を実装してみた