2回目のパススルーでエラーが発生し、オラクルからデータをコピーするとエラーが発生する

Question

vbaについては非常に時折アマチュアですが、これはまっすぐであるはずですか？

oracle dbの各表の内容をExcelファイルの別々のタブにコピーしようとしています。コードは、Excelファイルの最初のタブのリストから必要なテーブルの名前を取得し、配列に格納します。私はその後、各テーブルの新しいタブを作成し、データをコピーする配列をループしようとしています。このコードは、For Eachループを最初に通過するときに機能しますが、2番目のテーブルのrsを開こうとする箇所では常に失敗します。ループの内側と外側でレコードセットの開閉をさまざまな方法で試してみましたが、無駄です。データをコピーした後にrsをクローズしないと、rs.Open（sSQL）に接続したときにクローズされていないというエラーが表示されます。接続を閉じると、同じエラーが発生します。ポイントは....

Sub Ora_Connection() 
Dim con As ADODB.Connection 
Dim rs As ADODB.Recordset 
Dim query As String   ' a string to contain the db connection data 
Dim myTABLELIST As Variant   ' a variant to contain the list of oracle tables that contain data that we want to copy to excel 
Dim lArr As Variant 


' copy contents of TABLELIST into vb array 
myTABLELIST = Worksheets("TABLE_LIST").ListObjects("TABLELIST").DataBodyRange.Value 


' add a tab for every table in list 
For Each lArr In myTABLELIST 

     ' connect to oracle db 
     Set con = New ADODB.Connection 
     con.CursorLocation = adUseClient ' avoid error 3705 - doesn't do anything 
     Set rs = New ADODB.Recordset 
     '---- Replace HOST and COONECT_DATA with values for the db you are connecting to 
     strCon = "Driver={Microsoft ODBC for Oracle}; " & _ 
     "CONNECTSTRING=(DESCRIPTION=" & _ 
     "(ADDRESS=(PROTOCOL=TCP)" & _ 
     "(HOST=myHost)(PORT=1521))" & _ 
     "(CONNECT_DATA=(SID=mySID))); uid=myUID; pwd=myPWD;" 
     '--- Open the above connection string. 
     con.Open (strCon) 
     '--- Now connection is open and you can use queries to execute them. 
     '--- It will be open till you close the connection 

     ' make the connection able to travel only forwards through the recordset, so the query runs faster 
     rs.CursorType = adOpenForwardOnly 



    Sheets.Add After:=Sheets(Sheets.Count) 
    ActiveSheet.Name = lArr 

    'creat SQl statement that uses table name in array 
    sSQL = "SELECT * FROM " & lArr 
    'If Not rs.State = adStateClosed Then 
    'MsgBox "The recordset is already open" 
    'End If 
    rs.Open (sSQL), con 
    Worksheets(lArr).Activate 
    ' copy column header from source data into row 1 
    For iCols = 0 To rs.Fields.Count - 1 
    ActiveSheet.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name 
    Next 
    ' copy all data rows from source data into range starting at A2 
    ActiveSheet.Range(ActiveSheet.Cells(1, 1), _ 
    ActiveSheet.Cells(1, rs.Fields.Count)).Font.Bold = True 
    ActiveSheet.Range("A2").CopyFromRecordset rs 


Next lArr 



' clear recordset and close connection 
Set rs = Nothing 
Set con = Nothing 

End Sub 

Answer 1

これは動作するはずです：

Sub Ora_Connection() 

    Dim con As ADODB.Connection 
    Dim rs As ADODB.Recordset 
    Dim myTABLELIST As Variant, strCon As String, iCols As Long 
    Dim lArr As Variant, ws As Worksheet, r As Long, wb As Workbook 

    Set wb = ThisWorkbook 

    myTABLELIST = wb.Worksheets("TABLE_LIST").ListObjects("TABLELIST").DataBodyRange.Value 

    Set con = New ADODB.Connection 
    strCon = "yourConnectionInfoHere" 
    con.Open strCon 

    ' add a tab for every table in list 
    For r = 1 To UBound(myTABLELIST, 1) 

     lArr = myTABLELIST(r, 1) 

     Set rs = con.Execute("SELECT * FROM " & lArr) 
     Set ws = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count)) 
     ws.Name = lArr 
     For iCols = 0 To rs.Fields.Count - 1 
      ws.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name 
     Next 
     ws.Cells(1, 1).Resize(1, rs.Fields.Count).Font.Bold = True 
     If Not rs.EOF Then ws.Range("A2").CopyFromRecordset rs 

    Next r 

    Set rs = Nothing 
    con.Close 
    Set con = Nothing 

End Sub