I have the following code, where .Fields... is not getting executed. Loop is directly closing the connection without adding records into table.
Code:
Sub insertIntoTable()
Dim moviesConn As ADODB.Connection
Dim moviesData As ADODB.Recordset
Dim moviesField As ADODB.Fields
Dim r As Range
Set moviesConn = New ADODB.Connection
Set moviesData = New ADODB.Recordset
moviesConn.ConnectionString = conStrAccess
moviesConn.Open
On Error GoTo closeConnection
With moviesData
.ActiveConnection = moviesConn
.Source = "tblFilmDetails"
.LockType = adLockOptimistic
.CursorType = adOpenForwardOnly
.Open
On Error GoTo closeRecordset
For Each r In Range("A3", Range("A2").End(xlDown))
.AddNew
.Fields("Title").Value = r.Offset(0, 1).Value
.Fields("Release_Date").Value = r.Offset(0, 2).Value
.Fields("Length").Value = r.Offset(0, 3).Value
.Fields("Genere").Value = r.Offset(0, 4).Value
.Update
Next r
End With
closeRecordset:
moviesData.Close
closeConnection:
moviesConn.Close
End Sub
Please suggest
I was able to get your code to work using this connection string:
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\best buy\Desktop\test.accdb;Persist Security Info=False;"
We can rule out data mismatch error because it throws a 3219 Runtime Error Operation before closing the connection.
Range("A3", Range("A2").End(xlDown)) should probably be changed Range("A2", Range("A" & Rows.Count).End(xlup)) for two reasons:
It skips row 2
If there is no data beyond row 2 you will add 1048575 empty records (Ask me how I know)
If you have a large dataset you should comment out .Update and use .UpdateBatch after you have added all the records. This will greatly improve performance.
For Each r In Range("A3", Range("A2").End(xlDown))
.AddNew
.Fields("Title").Value = r.Offset(0, 1).Value
.Fields("Release_Date").Value = r.Offset(0, 2).Value
.Fields("Length").Value = r.Offset(0, 3).Value
.Fields("Genere").Value = r.Offset(0, 4).Value
'.Update
Next r
.UpdateBatch
Note: If you have the table open while adding the records then you have to press F5 to refresh the table and view the new data.
Related
I’m using ADO to run SQL query in VBA. I’ve done this quite a lot, and everything works properly.
However, I’m advancing to a more sophisticated query, where I need to input an unknown number of conditional strings. In short:
SELECT * FROM database.dbo.table
WHERE Col1 IN (‘val1’, ‘val2’, ..., ‘valn’)
I have a set of data on my worksheet, which changes every time. The data are of the same string format each time, but number of cells with values varies. I want to execute above query, using my n number of variables in the WHERE-statement.
Example of query with 5 variables from worksheet:
SELECT * FROM database.dbo.table
WHERE Col1 IN (‘000165234’, ‘000165238’, ‘000165231’, ‘000165232’, ‘000165239’)
Any pointers to the right direction are greatly appreciated.
My biggest issue is how to handle the unknown number of variables.
Constraints: will always be at least 1 cell with value, and never more than 60.
Notes: Data is also stored in an array, and does not necessarily needs to be printed on the worksheet.
Updated code
Sub TEST()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Dim fRow As Long
Dim sRow As Integer
Dim col As Integer
Dim arr() As Variant
Dim coll As New Collection
col = 3
sRow = 6
With ws1
fRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
With ws2
fRow2 = .Cells(.Rows.Count, 12).End(xlUp).Row
End With
For i = sRow To fRow
With ws1
ele1= .Cells(i, 2).Value
ele2= "000" & .Cells(i, 4).Value
If ele1<> "" Then
coll.Add Array(ele2)
End If
End With
Next
On Error GoTo gotcha
ReDim arr(1 To coll.Count, 1 To 2)
For i = 1 To coll.Count
arr(i, 1) = coll(i)(0)
Next
gotcha:
Debug.Print Err.number
If Err.number = 9 Then
MsgBox "Error"
Exit Sub
End If
ws2.Range("L29:M" & fRow2).ClearContents
ws2.Range("L29").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
Set conn = CreateObject("ADODB.Connection")
Dim fRow3 As Long
With ws2
fRow3 = .Cells(.Rows.Count, 13).End(xlUp).Row
End With
Dim CONNECTION As String
Dim QUERY As String
Dim WHERE As String
'Set connection and SELECT query
CONNECTION = "Provider=*.1;Persist Security Info=True;User ID=*; Password=*; Data Source=*;Initial Catalog=*"
selectpart = "SELECT *FROM database.dbo.table "
'### The error occurs here ###
conditionpart = "WHERE [COL1] IN ('" & Join(arr, "','") & "')"
GetBreakerQuantitiesQuery = selectpart & vbNewLine & conditionpart
QUERY = GetBreakerQuantitiesQuery
conn.Open CONNECTION
Set rs = CreateObject("ADODB.Recordset")
rs.ActiveConnection = conn
rs.Open QUERY
ws.Range("T6").CopyFromRecordset rs
ws.Range("T6:AL6").Copy
ws.Range("N7").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, True, True
ws.Range("T6:AL6").ClearContents
ws.Range("L6").Select
rs.Close
conn.Close
Set conn = Nothing
Set rs = Nothing
End Sub
Dim sql as string, arr
arr = Array("000165231", "000165232", "000165239")
sql = "SELECT * FROM database.dbo.table WHERE Col1 IN ('" & Join(arr, "','") & "')"
'use sql variable for your query
Use a 1-d array:
For i = sRow To fRow
With ws1
If Len(.Cells(i, 2).Value) > 0 Then
coll.Add "000" & .Cells(i, 4).Value
End If
End With
Next
On Error GoTo gotcha '??
ReDim arr(0 To coll.Count-1)
For i = 1 To coll.Count
arr(i - 1) = coll(i)
Next
'....
ws2.Range("L29").Resize(UBound(arr) + 1, 1).Value = Application.Transpose(arr)
I have a table on Excel, range A1:Sn (where n is the LastRow). Previously I used to to loop in each row and insert it one by one.
This works fine, and I can resort back to it, but I am looking to insert the entire recordset ("A1:S" & LastRow) into SQL Table, rather than looping row by row.
The reason for this is if I am inserting as a whole recordset will be treated as 1x operation, and therefore will make generating a receipt id for multiple users significantly easier.
Code
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Set con = New ADODB.Connection
Set rs = New ADODB.Recordset
dim i as long
dim LastRow as long
LastRow = Sheets("Project_Name").Cells(Rows.count, "B").End(xlUp).row
con.Open "Provider=SQLOLEDB; Data Source=LO1WPFSASDB001 ; Initial Catalog=database; User ID=username; Password=password; Trusted_Connection=no"
rs.Open "SELECT * from table;", con, adOpenKeyset, adLockOptimistic
With rs
for i = 1 to LastRow
.addnew
!somevalue = range("A1:S" & LastRow)
.update
next
.Close
End With
con.Close
Set con = Nothing
Set rs = Nothing
I cannot seem to get it to work. I would appreciate your input.
It seems that you need to change the loop structure.
Dim con As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim strConn As String
Dim i As Long, j As Integer
Dim LastRow As Long
Dim vDB
Set con = New ADODB.Connection
Set Rs = New ADODB.Recordset
LastRow = Sheets("Project_Name").Cells(Rows.Count, "B").End(xlUp).Row
vDB = Sheets("Project_Name").Range("A1:S" & LastRow)
strConn = "Provider=SQLOLEDB; Data Source=LO1WPFSASDB001 ; Initial Catalog=database; User ID=username; Password=password; Trusted_Connection=no"
With Rs
.ActiveConnection = strConn
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.Open
For i = 1 To UBound(vDB, 1)
.AddNew
For j = 1 To UBound(vDB, 2)
.Fields(j) = vDB(i, j)
Next j
.Update
Next i
End With
With Rs
End With
Set Rs = Nothing
You still need to loop the data on excel and insert/add it.
Following your current code. The second loop is to insert the columns.
for i = 1 to LastRow
.addnew
For n = 0 To .Fields.Count - 1
.Fields(n).Value = Cells(i, n + 1)
Next n
.update
next
I would take a different approach to avoid the second loop. Instead of using .addnew I would loop the data in excel, create the INSERT Strings and do an .Execute "INSERT ..." instead. You can skip the rs.Open using this method, just opening the connection and executing on it is fine.
for i = 1 to LastRow
sqlString = "INSERT INTO TableName (Field1, Field2, Field3, Field4...) VALUES (Cells(i, 1), Cells(i, 2), Cells(i, 3), Cells(i, 4)...)"
con.Execute(sqlString)
next
Edit: Using the insert method, you must enclose text values with ' marks otherwise the INSERT statement will return an invalid value type.
I'm trying to load a table from Microsoft Access and paste it into Excel cells with VBA.
My path is correctly finding my .accdb file and does error until the first Cells(row x).Value = statement.
The "OpenRecordset" method not referencing a table, makes me feel like I shouldn't be passing in the name of the table- or using a different method altogether.
I get an error: "Run-time error '3265' Application-defined or object-defined error
Here is my code below:
Sub ImportAccessButton()
Dim row As Integer
Dim dbPassengerCarMileage As Database
Dim rstPassengerCarMileage As Recordset
row = 3
Set dbPassengerCarMileage = OpenDatabase(ThisWorkbook.Path & "\Cars.accdb")
Set rstPassengerCarMileage = dbPassengerCarMileage.OpenRecordset("Amber")
If Not rstPassengerCarMileage.BOF Then
Do Until rstPassengerCarMileage.EOF
Cells(row, 1).Value = rstPassengerCarMileage!MAKE
Cells(row, 2).Value = rstPassengerCarMileage!Model
Cells(row, 3).Value = rstPassengerCarMileage!VOL
Cells(row, 4).Value = rstPassengerCarMileage!HP
Cells(row, 5).Value = rstPassengerCarMileage!MPG
Cells(row, 6).Value = rstPassengerCarMileage!SP
Cells(row, 7).Value = rstPassengerCarMileage!WT
row = row + 1
rstPassengerCarMileage.MoveNext
Loop
End If
'Close database and Cleanup objects
rstPassengerCarMileage.Close
dbPassengerCarMileage.Close
Set rstPassengerCarMileage = Nothing
Set dbPassengerCarMileage = Nothing
End Sub
It uses ADODB. The CopyFromRecordset command speeds up.
Sub ImportAccessButton()
Dim Rs As Object
Dim strConn As String
Dim i As Integer
Dim Ws As Worksheet
Dim strSQL As String
set Ws = ActiveSheet
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.Path & "\Cars.accdb" & ";"
strSQL = "SELECT * FROM Amber"
Set Rs = CreateObject("ADODB.Recordset")
Rs.Open strSQL, strConn
If Not Rs.EOF Then
With Ws
.Range("a2").CurrentRegion.ClearContents
For i = 0 To Rs.Fields.Count - 1
.Cells(2, i + 1).Value = Rs.Fields(i).Name
Next
.Range("a" & 3).CopyFromRecordset Rs
End With
End If
Rs.Close
Set Rs = Nothing
End Sub
While showing details of pivottable with VBA method:
Range("D10").ShowDetail = True
I would like to choose only the columns I want, in a specified order I want. Let's say in source data of pivot table I have 10 columns (col1, col2, col3, ... , col10), and while expanding details with VBA I want to show just 3 columns (col7, col2, col5).
Is it possible to do it in SQL style like:
SELECT col7, col2, col5 from Range("D10").ShowDetail
I tuned this as a function so that you can get the sheet reference like this
Set DetailSheet = test_Przemyslaw_Remin(Range("D10"))
Here is the function :
Public Function test_Przemyslaw_Remin(RangeToDetail As Range) As Worksheet
Dim Ws As Worksheet
RangeToDetail.ShowDetail = True
Set Ws = ActiveSheet
Ws.Range("A1").Select
Ws.Columns("H:J").Delete
Ws.Columns("F:F").Delete
Ws.Columns("C:D").Delete
Ws.Columns("A:A").Value = Ws.Columns("D:D").Value
Ws.Columns("D:D").Clear
Set test_Przemyslaw_Remin = Ws
End Function
Solution with Headers' names
Results will be shown in the order set in the string in the ScanHeaders function
Public Sub SUB_Przemyslaw_Remin(RangeToDetail As Range)
Dim Ws As Worksheet, _
MaxCol As Integer, _
CopyCol As Integer, _
HeaD()
RangeToDetail.ShowDetail = True
Set Ws = ActiveSheet
HeaD = ScanHeaders(Ws, "HeaderName1/HeaderName2/HeaderName3")
For i = LBound(HeaD, 1) To UBound(HeaD, 1)
If HeaD(i, 2) > MaxCol Then MaxCol = HeaD(i, 2)
Next i
With Ws
.Range("A1").Select
.Columns(ColLet(MaxCol + 1) & ":" & ColLet(.Columns.Count)).Delete
'To start filling the data from the next column and then delete what is before
CopyCol = MaxCol + 1
For i = LBound(HeaD, 1) To UBound(HeaD, 1)
.Columns(ColLet(CopyCol) & ":" & ColLet(CopyCol)).Value = _
.Columns(HeaD(i, 3) & ":" & HeaD(i, 3)).Value
CopyCol = CopyCol + 1
Next i
.Columns("A:" & ColLet(MaxCol)).Delete
End With
End Sub
The scan headers function, that will return a array with in row : Header's Name,
Column number, Column letter :
Public Function ScanHeaders(aSheet As Worksheet, Headers As String, Optional Separator As String = "/") As Variant
Dim LastCol As Integer, _
ColUseName() As String, _
ColUse()
ColUseName = Split(Headers, Separator)
ReDim ColUse(1 To UBound(ColUseName) + 1, 1 To 3)
For i = 1 To UBound(ColUse)
ColUse(i, 1) = ColUseName(i - 1)
Next i
With Sheets(SheetName)
LastCol = .Cells(1, 1).End(xlToRight).Column
For k = LBound(ColUse, 1) To UBound(ColUse, 1)
For i = 1 To LastCol
If .Cells(1, i) <> ColUse(k, 1) Then
If i = LastCol Then MsgBox "Missing data : " & ColUse(k, 1), vbCritical, "Verify data integrity"
Else
ColUse(k, 2) = i
Exit For
End If
Next i
ColUse(k, 3) = ColLet(ColUse(k, 2))
Next k
End With
ScanHeaders = ColUse
End Function
And the function to get the Column's letter from the Column's number :
Public Function ColLet(x As Integer) As String
With ActiveSheet.Columns(x)
ColLet = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)
End With
End Function
Yes, I have finally done it. This collection of three subs allows you make SQL statements on just used ShowDetail on PivotTable.
After running Range("D10").ShowDetail = True run macro RunSQLstatementsOnExcelTable
Just adjust the SQL according to your needs:
select [Col7],[Col2],[Col5] from [DetailsTable] where [Col7] is not null
Just leave [DetailsTable] as it is. It will be changed automatically into ActiveSheet with details data.
Calling the sub DeleteAllWhereColumnIsNull is optional. This approach is the same as delete from table WHERE Column is null in SQL but it guarantees that the key column will not lose its formatting. Your formatting is read from the first eight rows and it will be turned into text i.e. if you have NULLs in the first rows. More about corrupt formatting of ADO you may find here.
You do not have to enable references to ActiveX libraries using the macros. It is important if you want to distribute your files.
You may experiment with different connection strings. There are three different left just in case. All of them worked for me.
Sub RunSQLstatementsOnExcelTable()
Call DeleteAllWhereColumnIsNull("Col7") 'Optionally delete all rows with empty value on some column to prevent formatting issues
'In the SQL statement use "from [DetailsTable]"
Dim SQL As String
SQL = "select [Col7],[Col2],[Col5] from [DetailsTable] where [Col7] is not null order by 1 desc" '<-- Here goes your SQL code
Call SelectFromDetailsTable(SQL)
End Sub
Sub SelectFromDetailsTable(ByVal SQL As String)
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.UsedRange.Select 'This stupid line proved to be crucial. If you comment it, then you may get error in line oRS.Open
Dim InputSheet, OutputSheet As Worksheet
Set InputSheet = ActiveSheet
Worksheets.Add
DoEvents
Set OutputSheet = ActiveSheet
Dim oCn As Object
Set oCn = CreateObject("ADODB.Connection")
Dim cmd As Object
Set cmd = CreateObject("ADODB.Command")
Dim oRS As Object
Set oRS = CreateObject("ADODB.Recordset")
Dim strFile As String
strFile = ThisWorkbook.FullName
'------- Choose whatever connection string you like, all of them work well -----
Dim ConnString As String
ConnString = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & strFile & ";HDR=Yes';" 'works good
'ConnString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";" 'IMEX=1 data as text
'ConnString = "Provider=Microsoft.Jet.OLEDB.4.0;excel 8.0;DATABASE=" & strFile 'works good
'ConnString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & strFile 'works good
Debug.Print ConnString
oCn.ConnectionString = ConnString
oCn.Open
'Dim SQL As String
SQL = Replace(SQL, "[DetailsTable]", "[" & InputSheet.Name & "$] ")
Debug.Print SQL
oRS.Source = SQL
oRS.ActiveConnection = oCn
oRS.Open
OutputSheet.Activate
'MyArray = oRS.GetRows
'Debug.Print MyArray
'----- Method 1. Copy from OpenRowSet to Range ----------
For intFieldIndex = 0 To oRS.Fields.Count - 1
OutputSheet.Cells(1, intFieldIndex + 1).Value = oRS.Fields(intFieldIndex).Name
Next intFieldIndex
OutputSheet.Cells(2, 1).CopyFromRecordset oRS
ActiveSheet.ListObjects.Add(xlSrcRange, Application.ActiveSheet.UsedRange, , xlYes).Name = "MyTable"
'ActiveSheet.ListObjects(1).Range.EntireColumn.AutoFit
ActiveSheet.UsedRange.EntireColumn.AutoFit
'----- Method 2. Copy from OpenRowSet to Table ----------
'This method sucks because it does not prevent losing formatting
'Dim MyListObject As ListObject
'Set MyListObject = OutputSheet.ListObjects.Add(SourceType:=xlSrcExternal, _
'Source:=oRS, LinkSource:=True, _
'TableStyleName:=xlGuess, destination:=OutputSheet.Cells(1, 1))
'MyListObject.Refresh
If oRS.State <> adStateClosed Then oRS.Close
If Not oRS Is Nothing Then Set oRS = Nothing
If Not oCn Is Nothing Then Set oCn = Nothing
'remove unused ADO connections
Dim conn As WorkbookConnection
For Each conn In ActiveWorkbook.Connections
Debug.Print conn.Name
If conn.Name Like "Connection%" Then conn.Delete 'In local languages the default connection name may be different
Next conn
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Sub DeleteAllWhereColumnIsNull(ColumnName As String)
Dim RngHeader As Range
Debug.Print ActiveSheet.ListObjects(1).Name & "[[#Headers],[" & ColumnName & "]]"
Set RngHeader = Range(ActiveSheet.ListObjects(1).Name & "[[#Headers],[" & ColumnName & "]]")
Debug.Print RngHeader.Column
Dim ColumnNumber
ColumnNumber = RngHeader.Column
ActiveSheet.ListObjects(1).Sort.SortFields.Clear
ActiveSheet.ListObjects(1).HeaderRowRange(ColumnNumber).Interior.Color = 255
ActiveSheet.ListObjects(1).ListColumns(ColumnNumber).DataBodyRange.NumberFormat = "#,##0.00"
With ActiveSheet.ListObjects(1).Sort
With .SortFields
.Clear
'.Add ActiveSheet.ListObjects(1).HeaderRowRange(ColumnNumber), SortOn:=xlSortOnValues, Order:=sortuj
.Add RngHeader, SortOn:=xlSortOnValues, Order:=xlAscending
End With
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Delete from DetailsTable where [ColumnName] is null
On Error Resume Next 'If there are no NULL cells, just skip to next row
ActiveSheet.ListObjects(1).ListColumns(ColumnNumber).DataBodyRange.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Err.Clear
ActiveSheet.UsedRange.Select 'This stupid thing proved to be crucial. If you comment it, then you will get error with Recordset Open
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim PTCll As PivotCell
On Error Resume Next
Set PTCll = Target.PivotCell
On Error GoTo 0
If Not PTCll Is Nothing Then
If PTCll.PivotCellType = xlPivotCellValue Then
Cancel = True
Target.ShowDetail = True
With ActiveSheet
ActiveSheet.Range("A1").Select
ActiveSheet.Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Columns("E:F").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Columns("F:I").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Columns("J:R").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Columns("H:I").Select
Selection.NumberFormat = "0.00"
ActiveSheet.Columns("H:I").EntireColumn.AutoFit
Selection.NumberFormat = "0.0"
Selection.NumberFormat = "0"
ActiveSheet.Cells.Select
ActiveSheet.Cells.EntireColumn.AutoFit
ActiveSheet.Range("A1").Select
End With
End If
End If
End Sub
Previously I was able to run some VBA that ran several SQL queries and put the results in separate columns in a single Excel worksheet. There was a reference set to Microsoft ActiveX Data Objects 2.8 Library (Tools, References in the VBE).
Although the code was working fine, recently I get an error message as follows -
Run-time error '-2147217913 (80040e07)'
Data type mismatch in criteria expression
Here is the code (the error appears in "rs.Open sql, cn, adOpenStatic" which is less than helpful). Please note that the same error appears in all VBA/SQL code I try to run, not just the code below.
Private Sub GetUniqueClassesListWithConditions()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strWkbPath As String
Dim sql As String
Dim buf As Variant
Dim i As Long
Dim j As Long
Dim iTimes As Integer
Dim iQuestion As Integer
Dim iCondition As Integer
Dim iLimit As Integer
Dim sCondition As String
Dim iColumn As Integer
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
strWkbPath = ThisWorkbook.FullName
Worksheets.Add After:=Sheets(Sheets.Count)
For iQuestion = 1 To 14
For iTimes = 1 To 5
Select Case iTimes
Case 1
iLimit = 7
sCondition = "Day"
Case 2
iLimit = 6
sCondition = "Time"
Case 3
iLimit = 16
sCondition = "Faculty"
Case 4
iLimit = 13
sCondition = "Department"
Case 5
iLimit = 6
sCondition = "Student Numbers"
End Select
For iCondition = 1 To iLimit
sql = "SELECT DISTINCT([Data$].Class) FROM [Data$] WHERE [Data$].Q" & iQuestion & " <> '-' AND [Data$]." & sCondition & " = " & iCondition
j = 0
Set cn = New ADODB.Connection
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Properties("Extended Properties") = "Excel 12.0;HDR=YES;IMEX=1"
cn.Open strWkbPath
Set rs = New ADODB.Recordset
rs.Open sql, cn, adOpenStatic
ReDim buf(0 To rs.Fields.Count - 1, 0)
For i = 0 To rs.Fields.Count - 1
buf(i, 0) = rs(i).Name
Next i
Do Until rs.EOF
j = j + 1
ReDim Preserve buf(0 To rs.Fields.Count - 1, 0 To j)
For i = 0 To rs.Fields.Count - 1
buf(i, j) = rs(i).Value
Next i
rs.MoveNext
Loop
rs.Close
cn.Close
Set cn = Nothing
Set rs = Nothing
iColumn = iColumn + 1
With ActiveSheet
.Cells(1, iColumn).Value = "Q" & iQuestion & ", " & sCondition & "=" & iCondition
.Cells(2, iColumn).Resize(UBound(buf, 2) + 1, UBound(buf, 1) + 1).Value = TransposeArray(buf)
End With
Next iCondition
iColumn = iColumn + 2
Next iTimes
Next iQuestion
With ActiveSheet
.Rows(1).Font.Bold = True
.Rows(2).EntireRow.Delete
.UsedRange.Columns.EntireColumn.AutoFit
On Error Resume Next
.Name = "Unique Classes List (Condtions)"
On Error GoTo 0
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
Private Function TransposeArray(buf)
Dim tmp()
Dim i As Long
Dim j As Long
ReDim tmp(UBound(buf, 2), UBound(buf, 1))
For i = LBound(buf, 1) To UBound(buf, 1)
For j = LBound(buf, 2) To UBound(buf, 2)
tmp(j, i) = buf(i, j)
Next j
Next i
TransposeArray = tmp
End Function
If somebody can help me get the code running and/or tell me what the problem is, I'd be very grateful.
Also, I'd like to do the same thing in Access. If I can export all of the results to an Excel file, even as different sheets in a workbook, it's easy for me to run some other code to combine the data into another worksheet. (I'm new to Access and know how to run SQL, but have no idea how to automate it, including putting the results in different "columns" and exporting it)
Should mention my SQL "skills" are basic and I'm learning from w3schools as I go along (hope I'm not offending anybody here.
Thanks for your help in advance.