I have a bunch of rows in Excel that I want to paste into a new table in MS SQL. Is there a simple way ?
If you have SQL Server Management Studio, you can just Copy from Excel and Paste into the table in Management Studio, using your mouse. Just
Go to the table you want to paste into.
Select "Edit Top 200 Rows".
Right-click anywhere and select Paste.
Before you do this, you must match the columns between Excel and Management Studio. Also, you must place any non-editable columns last (right-most) using the Table Designer in Management Studio.
The whole procedure takes seconds (to set-up and start - not necessarily to execute) and doesn't require any SQL statements.
Regarding empty database tables and SSMS v18.1+.
I have used this technique successfully in the past:
Using Excel to generate Inserts for SQL Server
(...) Skip a column (or use it for notes) and then type something like the
following formula in it:
="insert into tblyourtablename (yourkeyID_pk, intmine, strval) values ("&A4&", "&B4&", N'"&C4&"')"
Now you’ve got your insert statement for
a table with your primary key (PK), an integer and a unicode string. (...)
Excel
In Excel, highlight and copy the data you want to paste into SQL.
SQL
Create the table with the desired column names and give you table a name.
*Make sure Identity Specification is Yes, so it will auto increment your
Identity column.
Find your table, and right click on it and choose Edit Top 200 Rows from the dialog-box.
Right click on the empty row with the * sign and select paste from the dialog-box
For future references:
You can copy-paste data from en excel-sheet to an SQL-table by doing so:
Select the data in Excel and press Ctrl + C
In SQL Server Management Studio right click the table and choose Edit Top 200 Rows
Scroll to the bottom and select the entire empty row by clicking on the row header
Paste the data by pressing Ctrl + V
Note: Often tables have a first column which is an ID-column with an auto generated/incremented ID. When you paste your data it will start inserting the leftmost selected column in Excel into the leftmost column in SSMS thus inserting data into the ID-column. To avoid that keep an empty column at the leftmost part of your selection in order to skip that column in SSMS. That will result in SSMS inserting the default data which is the auto generated ID.
Furthermore you can skip other columns by having empty columns at the same ordinal positions in the Excel sheet selection as those columns to be skipped. That will make SSMS insert the default value (or NULL where no default value is specified).
I have developed an Excel VBA Macro for cutting and pasting any selection from Excel into SQL Server, creating a new table. The macro is great for quick and dirty table creations up to a few thousand rows and multiple columns (It can theoretically manage up to 200 columns). The macro attempts to automatically detect header names and assign the most appropriate datatype to each column (it handles varchar columns upto 1000 chars).
Recommended Setup procedure:
Make sure Excel is enabled to run macros. (File->Options->Trust Center->Trust Center Settings->Macro Settings->Enable all macros..)
Copy the VBA code below to the module associated with your personal workbook (So that the Macro will be available for all worksheets)
Assign an appropriate keystroke to the macro ( I have assigned Ctrl Shift X)
Save your personal workbook
Use of Macro
Select the cells in Excel (including column headers if they exist) to be transferred to SQL
Press the assigned keyword combination that you have assigned to run the macro
Follow the prompts. (Default table name is ##Table)
Paste the clipboard contents into a SSMS window and run the generated SQL code.
BriFri 238
VBA Code:
Sub TransferToSQL()
'
' TransferToSQL Macro
' This macro prepares data for pasting into SQL Server and posts it to the clipboard for inserting into SSMS
' It attempts to automatically detect header rows and does a basic analysis of the first 15 rows to determine the most appropriate datatype to use handling text entries upto 1000 chars.
'
' Max Number of Columns: 200
'
' Keyboard Shortcut: Ctrl+Shift+X
'
' ver Date Reason
' === ==== ======
' 1.6 06/2012 Fixed bug that prevented auto exit if no selection made / auto exit if blank Tablename entered or 'cancel' button pressed
' 1.5 02/2012 made use of function fn_ColLetter to retrieve the Column Letter for a specified column
' 1.4 02/2012 Replaces any Tabs in text data to spaces to prevent Double quotes being output in final results
' 1.3 02/2012 Place the 'drop table if already exists' code into a separate batch to prevent errors when inserting new table with same name but different shape and > 100 rows
' 1.2 01/2012 If null dates encountered code to cast it as Null rather than '00-Jan-1900'
' 1.1 10/2011 Code to drop the table if already exists
' 1.0 03/2011 Created
Dim intLastRow As Long
Dim intlastColumn As Integer
Dim intRow As Long
Dim intDataStartRow As Long
Dim intColumn As Integer
Dim strKeyWord As String
Dim intPos As Integer
Dim strDataTypeLevel(4) As String
Dim strColumnHeader(200) As String
Dim strDataType(200) As String
Dim intRowCheck As Integer
Dim strFormula(20) As String
Dim intHasHeaderRow As Integer
Dim strCellRef As String
Dim intFormulaCount As Integer
Dim strSQLTableName As String
Dim strSQLTableName_Encap As String
Dim intdataTypelevel As Integer
Const strConstHeaderKeyword As String = "ID,URN,name,Title,Job,Company,Contact,Address,Post,Town,Email,Tele,phone,Area,Region,Business,Total,Month,Week,Year,"
Const intConstMaxBatchSize As Integer = 100
Const intConstNumberRowsToAnalyse As Integer = 100
intHasHeaderRow = 0
strDataTypeLevel(1) = "VARCHAR(1000)"
strDataTypeLevel(2) = "FLOAT"
strDataTypeLevel(3) = "INTEGER"
strDataTypeLevel(4) = "DATETIME"
' Use current selection and paste to new temp worksheet
Selection.Copy
Workbooks.Add ' add temp 'Working' Workbook
' Paste "Values Only" back into new temp workbook
Range("A3").Select ' Goto 3rd Row
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' Copy Format of Selection
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' Copy Values of Selection
ActiveCell.SpecialCells(xlLastCell).Select ' Goto last cell
intLastRow = ActiveCell.Row
intlastColumn = ActiveCell.Column
' Check to make sure that there are cells which are selected
If intLastRow = 3 And intlastColumn = 1 Then
Application.DisplayAlerts = False ' Temporarily switch off Display Alerts
ActiveWindow.Close ' Delete newly created worksheet
Application.DisplayAlerts = True ' Switch display alerts back on
MsgBox "*** Please Make selection before running macro - Terminating ***", vbOKOnly, "Transfer Data to SQL Server"
Exit Sub
End If
' Prompt user for Name of SQL Server table
strSQLTableName = InputBox("SQL Server Table Name?", "Transfer Excel Data To SQL", "##Table")
' if blank table name entered or 'Cancel' selected then exit
If strSQLTableName = "" Then
Application.DisplayAlerts = False ' Temporarily switch off Display Alerts
ActiveWindow.Close ' Delete newly created worksheet
Application.DisplayAlerts = True ' Switch display alerts back on
Exit Sub
End If
' encapsulate tablename with square brackets if user has not already done so
strSQLTableName_Encap = Replace(Replace(Replace("[" & Replace(strSQLTableName, ".", "].[") & "]", "[]", ""), "[[", "["), "]]", "]")
' Try to determine if the First Row is a header row or contains data and if a header load names of Columns
Range("A3").Select
For intColumn = 1 To intlastColumn
' first check to see if the first row contains any pure numbers or pure dates
If IsNumeric(ActiveCell.Value) Or IsDate(ActiveCell.Value) Then
intHasHeaderRow = vbNo
intDataStartRow = 3
Exit For
Else
strColumnHeader(intColumn) = ActiveCell.Value
ActiveCell.Offset(1, 0).Range("A1").Select ' go to the row below
If IsNumeric(ActiveCell.Value) Or IsDate(ActiveCell.Value) Then
intHasHeaderRow = vbYes
intDataStartRow = 4
End If
ActiveCell.Offset(-1, 0).Range("A1").Select ' go back up to the first row
If intHasHeaderRow = 0 Then ' if still not determined if header exists: Look for header using keywords
intPos = 1
While intPos < Len(strConstHeaderKeyword) And intHasHeaderRow = 0
strKeyWord = Mid$(strConstHeaderKeyword, intPos, InStr(intPos, strConstHeaderKeyword, ",") - intPos)
If InStr(1, ActiveCell.Value, strKeyWord) > 0 Then
intHasHeaderRow = vbYes
intDataStartRow = 4
End If
intPos = InStr(intPos, strConstHeaderKeyword, ",") + 1
Wend
End If
End If
ActiveCell.Offset(0, 1).Range("A1").Select ' Goto next column
Next intColumn
' If auto header row detection has failed ask the user to manually select
If intHasHeaderRow = 0 Then
intHasHeaderRow = MsgBox("Does current selection have a header row?", vbYesNo, "Auto header row detection failure")
If intHasHeaderRow = vbYes Then
intDataStartRow = 4
Else
intDataStartRow = 3
End If
End If
' *** Determine the Data Type of each Column ***
' Go thru each Column to find Data types
If intLastRow < intConstNumberRowsToAnalyse Then ' Check the first intConstNumberRowsToAnalyse rows or to end of selection whichever is less
intRowCheck = intLastRow
Else
intRowCheck = intConstNumberRowsToAnalyse
End If
For intColumn = 1 To intlastColumn
intdataTypelevel = 5
For intRow = intDataStartRow To intRowCheck
Application.Goto Reference:="R" & CStr(intRow) & "C" & CStr(intColumn)
If ActiveCell.Value = "" Then ' ignore blank (null) values
ElseIf IsDate(ActiveCell.Value) = True And Len(ActiveCell.Value) >= 8 Then
If intdataTypelevel > 4 Then intdataTypelevel = 4
ElseIf IsNumeric(ActiveCell.Value) = True And InStr(1, CStr(ActiveCell.Value), ".") = 0 And (Left(CStr(ActiveCell.Value), 1) <> "0" Or ActiveCell.Value = "0") And Len(ActiveCell.Value) < 10 Then
If intdataTypelevel > 3 Then intdataTypelevel = 3
ElseIf IsNumeric(ActiveCell.Value) = True And InStr(1, CStr(ActiveCell.Value), ".") >= 1 Then
If intdataTypelevel > 2 Then intdataTypelevel = 2
Else
intdataTypelevel = 1
Exit For
End If
Next intRow
If intdataTypelevel = 5 Then intdataTypelevel = 1
strDataType(intColumn) = strDataTypeLevel(intdataTypelevel)
Next intColumn
' *** Build up the SQL
intFormulaCount = 1
If intHasHeaderRow = vbYes Then ' *** Header Row ***
Application.Goto Reference:="R4" & "C" & CStr(intlastColumn + 1) ' Goto next column in first data row of selection
strFormula(intFormulaCount) = "= ""SELECT "
For intColumn = 1 To intlastColumn
If strDataType(intColumn) = "DATETIME" Then ' Code to take Excel Dates back to text
strCellRef = "Text(" & fn_ColLetter(intColumn) & "4,""dd-mmm-yyyy hh:mm:ss"")"
ElseIf strDataType(intColumn) = "VARCHAR(1000)" Then
strCellRef = "SUBSTITUTE(" & fn_ColLetter(intColumn) & "4,""'"",""''"")" ' Convert any single ' to double ''
Else
strCellRef = fn_ColLetter(intColumn) & "4"
End If
strFormula(intFormulaCount) = strFormula(intFormulaCount) & "CAST('""& " & strCellRef & " & ""' AS " & strDataType(intColumn) & ") AS [" & strColumnHeader(intColumn) & "]"
If intColumn < intlastColumn Then
strFormula(intFormulaCount) = strFormula(intFormulaCount) + ", "
Else
strFormula(intFormulaCount) = strFormula(intFormulaCount) + " UNION ALL """
End If
' since each cell can only hold a maximum no. of chars if Formula string gets too big continue formula in adjacent cell
If Len(strFormula(intFormulaCount)) > 700 And intColumn < intlastColumn Then
strFormula(intFormulaCount) = strFormula(intFormulaCount) + """"
intFormulaCount = intFormulaCount + 1
strFormula(intFormulaCount) = "= """
End If
Next intColumn
' Assign the formula to the cell(s) just right of the selection
For intColumn = 1 To intFormulaCount
ActiveCell.Value = strFormula(intColumn)
If intColumn < intFormulaCount Then ActiveCell.Offset(0, 1).Range("A1").Select ' Goto next column
Next intColumn
' Auto Fill the formula for the full length of the selection
ActiveCell.Offset(0, -intFormulaCount + 1).Range("A1:" & fn_ColLetter(intFormulaCount) & "1").Select
If intLastRow > 4 Then Selection.AutoFill Destination:=Range(fn_ColLetter(intlastColumn + 1) & "4:" & fn_ColLetter(intlastColumn + intFormulaCount) & CStr(intLastRow)), Type:=xlFillDefault
' Go to start row of data selection to add 'Select into' code
ActiveCell.Value = "SELECT * INTO " & strSQLTableName_Encap & " FROM (" & ActiveCell.Value
' Go to cells above data to insert code for deleting old table with the same name in separate SQL batch
ActiveCell.Offset(-1, 0).Range("A1").Select ' go to the row above
ActiveCell.Value = "GO"
ActiveCell.Offset(-1, 0).Range("A1").Select ' go to the row above
If Left(strSQLTableName, 1) = "#" Then ' temp table
ActiveCell.Value = "IF OBJECT_ID('tempdb.." & strSQLTableName & "') IS NOT NULL DROP TABLE " & strSQLTableName_Encap
Else
ActiveCell.Value = "IF OBJECT_ID('" & strSQLTableName & "') IS NOT NULL DROP TABLE " & strSQLTableName_Encap
End If
' For Big selections (i.e. several 100 or 1000 rows) SQL Server takes a very long time to do a multiple union - Split up the table creation into many inserts
intRow = intConstMaxBatchSize + 4 ' add 4 to make sure 1st batch = Max Batch Size
While intRow < intLastRow
Application.Goto Reference:="R" & CStr(intRow - 1) & "C" & CStr(intlastColumn + intFormulaCount) ' Goto Row before intRow and the last column in formula selection
ActiveCell.Value = Replace(ActiveCell.Value, " UNION ALL ", " ) a") ' Remove last 'UNION ALL'
Application.Goto Reference:="R" & CStr(intRow) & "C" & CStr(intlastColumn + 1) ' Goto intRow and the first column in formula selection
ActiveCell.Value = "INSERT " & strSQLTableName_Encap & " SELECT * FROM (" & ActiveCell.Value
intRow = intRow + intConstMaxBatchSize ' increment intRow by intConstMaxBatchSize
Wend
' Delete the last 'UNION AlL' replacing it with brackets to mark the end of the last insert
Application.Goto Reference:="R" & CStr(intLastRow) & "C" & CStr(intlastColumn + intFormulaCount)
ActiveCell.Value = Replace(ActiveCell.Value, " UNION ALL ", " ) a")
' Select all the formula cells
ActiveCell.Offset(-intLastRow + 2, 1 - intFormulaCount).Range("A1:" & fn_ColLetter(intFormulaCount + 1) & CStr(intLastRow - 1)).Select
Else ' *** No Header Row ***
Application.Goto Reference:="R3" & "C" & CStr(intlastColumn + 1) ' Goto next column in first data row of selection
strFormula(intFormulaCount) = "= ""SELECT "
For intColumn = 1 To intlastColumn
If strDataType(intColumn) = "DATETIME" Then
strCellRef = "Text(" & fn_ColLetter(intColumn) & "3,""dd-mmm-yyyy hh:mm:ss"")" ' Format Excel dates into a text Date format that SQL will pick up
ElseIf strDataType(intColumn) = "VARCHAR(1000)" Then
strCellRef = "SUBSTITUTE(" & fn_ColLetter(intColumn) & "3,""'"",""''"")" ' Change all single ' to double ''
Else
strCellRef = fn_ColLetter(intColumn) & "3"
End If
' Since no column headers: Name each column "Column001",Column002"..
strFormula(intFormulaCount) = strFormula(intFormulaCount) & "CAST('""& " & strCellRef & " & ""' AS " & strDataType(intColumn) & ") AS [Column" & CStr(intColumn) & "]"
If intColumn < intlastColumn Then
strFormula(intFormulaCount) = strFormula(intFormulaCount) + ", "
Else
strFormula(intFormulaCount) = strFormula(intFormulaCount) + " UNION ALL """
End If
' since each cell can only hold a maximum no. of chars if Formula string gets too big continue formula in adjacent cell
If Len(strFormula(intFormulaCount)) > 700 And intColumn < intlastColumn Then
strFormula(intFormulaCount) = strFormula(intFormulaCount) + """"
intFormulaCount = intFormulaCount + 1
strFormula(intFormulaCount) = "= """
End If
Next intColumn
' Assign the formula to the cell(s) just right of the selection
For intColumn = 1 To intFormulaCount
ActiveCell.Value = strFormula(intColumn)
If intColumn < intFormulaCount Then ActiveCell.Offset(0, 1).Range("A1").Select ' Goto next column
Next intColumn
' Auto Fill the formula for the full length of the selection
ActiveCell.Offset(0, -intFormulaCount + 1).Range("A1:" & fn_ColLetter(intFormulaCount) & "1").Select
If intLastRow > 4 Then Selection.AutoFill Destination:=Range(fn_ColLetter(intlastColumn + 1) & "3:" & fn_ColLetter(intlastColumn + intFormulaCount) & CStr(intLastRow)), Type:=xlFillDefault
' Go to start row of data selection to add 'Select into' code
ActiveCell.Value = "SELECT * INTO " & strSQLTableName_Encap & " FROM (" & ActiveCell.Value
' Go to cells above data to insert code for deleting old table with the same name in separate SQL batch
ActiveCell.Offset(-1, 0).Range("A1").Select ' go to the row above
ActiveCell.Value = "GO"
ActiveCell.Offset(-1, 0).Range("A1").Select ' go to the row above
If Left(strSQLTableName, 1) = "#" Then ' temp table
ActiveCell.Value = "IF OBJECT_ID('tempdb.." & strSQLTableName & "') IS NOT NULL DROP TABLE " & strSQLTableName_Encap
Else
ActiveCell.Value = "IF OBJECT_ID('" & strSQLTableName & "') IS NOT NULL DROP TABLE " & strSQLTableName_Encap
End If
' For Big selections (i.e. serveral 100 or 1000 rows) SQL Server takes a very long time to do a multiple union - Split up the table creation into many inserts
intRow = intConstMaxBatchSize + 3 ' add 3 to make sure 1st batch = Max Batch Size
While intRow < intLastRow
Application.Goto Reference:="R" & CStr(intRow - 1) & "C" & CStr(intlastColumn + intFormulaCount) ' Goto Row before intRow and the last column in formula selection
ActiveCell.Value = Replace(ActiveCell.Value, " UNION ALL ", " ) a") ' Remove last 'UNION ALL'
Application.Goto Reference:="R" & CStr(intRow) & "C" & CStr(intlastColumn + 1) ' Goto intRow and the first column in formula selection
ActiveCell.Value = "INSERT " & strSQLTableName_Encap & " SELECT * FROM (" & ActiveCell.Value
intRow = intRow + intConstMaxBatchSize ' increment intRow by intConstMaxBatchSize
Wend
' Delete the last 'UNION AlL'
Application.Goto Reference:="R" & CStr(intLastRow) & "C" & CStr(intlastColumn + intFormulaCount)
ActiveCell.Value = Replace(ActiveCell.Value, " UNION ALL ", " ) a")
' Select all the formula cells
ActiveCell.Offset(-intLastRow + 1, 1 - intFormulaCount).Range("A1:" & fn_ColLetter(intFormulaCount + 1) & CStr(intLastRow)).Select
End If
' Final Selection to clipboard and Cleaning of data
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' Repaste "Values Only" back into cells
Selection.Replace What:="CAST('' AS", Replacement:="CAST(NULL AS", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False ' convert all blank cells to NULL
Selection.Replace What:="'00-Jan-1900 00:00:00'", Replacement:="NULL", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False ' convert all blank Date cells to NULL
Selection.Replace What:="'NULL'", Replacement:="NULL", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False ' convert all 'NULL' cells to NULL
Selection.Replace What:=vbTab, Replacement:=" ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False ' Replace all Tabs in cells to Space to prevent Double Quotes occuring in the final paste text
Selection.Copy
MsgBox "SQL Code has been added to clipboard - Please Paste into SSMS window", vbOKOnly, "Transfer to SQL"
Application.DisplayAlerts = False ' Temporarily switch off Display Alerts
ActiveWindow.Close ' Delete newly created worksheet
Application.DisplayAlerts = True ' Switch display alerts back on
End Sub
Function fn_ColLetter(Col As Integer) As String
Dim strColLetter As String
If Col > 26 Then
' double letter columns
strColLetter = Chr(Int((Col - 1) / 26) + 64) & _
Chr(((Col - 1) Mod 26) + 65)
Else
' single letter columns
strColLetter = Chr(Col + 64)
End If
fn_ColLetter = strColLetter
End Function
The simplest way is to create a computed column in XLS that would generate the syntax of the insert statement.
Then copy these insert into a text file and then execute on the SQL.
The other alternatives are to buy database connectivity add-on's for Excel and write VBA code to accomplish the same.
I'd think some datbases can import data from CSV (comma separated values) files, wich you can export from exel. Or at least it's quite easy to use a csv parser (find one for your language, don't try to create one yourself - it's harder than it looks) to import it to the database.
I'm not familiar with MS SQL but it wouldn't suprise me if it does support it directly.
In any case I think the requrement must be that the structure in the Exel sheet and the database table is similar.
If the interface works the way it did last I used it, you can select the region in Excel, copy it, open SQL Server and paste the data into the table as you would with Access.
Or you could setup an ODBC link between Excel and SQL Server.
why not just use export/import wizard in SSMS?
Can't you use VBA code to do the copy from excel and paste into SSMS operations?
Related
Task
My intention is to write back UserForm Listbox data to a sheet range in the most efficient way using the data field method.
Basic Method (esp. using data ranges)
AFAIK the most efficient method in order to write data to a range is using arrays. If data originate from a range it's preferrable to use data field arrays, which by default are two dimensional (one based arrays) and allow to
a) get data from sheet to array or
b) write back the array to sheet
with one code line:
Dim v ' As Variant
Dim rng As Range
Set rng = ...
' a) range to array
v = rng.Value
' b) array to range
rng.Value = v
Differences when using the ListBox data array
ListBox data are stored in a 2dim, but zero based array, e.g. ListBox1.List
[Hint: Therefore it's possible to create items using a predefined array instead of using the commonly known Add method, BTW restricted to only 10 columns (indexed 0 to 9). ]
Despite this difference, it is possible to read in the ListBox data and write them back to sheet with the described basic method:
' aa) ListBox data to array
v = Me.ListBox1.List
' bb) array to range
rng.Value = v
Furthermore, I remarked that by default the array columns count 10, so this won't correspond to the programmatically set ColumnCount. Therefore it's necessary to adapt the range checking the array dimensions, cf. debug protocol in the code example.
Problem and work around
Writing back the data field array to sheet in an one liner raises error 1004 (Application-defined or object-defined error) if there are items with a leading "==" string or comparable user inputs, as this can't be interpreted correctly by Excel.
My attempt to use
rng.Text = v
instead of
rng.value = v
did fail, too, causing a 424 object needed error.
Question
==> Is it possible to correct the potential error items with leading "=" character without looping through all array items using VBA or API methods? Any Code example is welcome to replace my work around (step 3 in code)
My Code
My code consists of four steps
1) create a 2dim data field array (v)
2) set a target range (rng)
3) [my work around correcting each array item]
4) write data back to worksheet
Private Sub CommandButton1_Click()
' declare variables
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Dump")
Dim s As String ' range address string
Dim sTest As String ' item test string
Dim v As Variant ' data field array
Dim rng As Range ' (target) range
Dim i As Long ' rows counter
Dim j As Long ' columns counter
Dim R As Long ' number of rows
Dim C As Integer ' number of columns
Dim lbxR As Long ' actual number of listbox items in data field
Dim lbxC As Integer ' actual number of listbox columns in data field
' Error Handler
On Error GoTo OOPS
' get programmatically defined listbox dimension
R = Me.ListBox1.ListCount
C = Me.ListBox1.ColumnCount
' clear sheet lines A2:A{r}
ws.Range(ws.Cells(2, 1), ws.Cells(R, C)).value = ""
' ===============================
' 1) create 2dim data field array
' -------------------------------
v = Me.ListBox1.List
' -------------------------------
' 2) set target range (rng)
' -------------------------------
' get actual data field dimension
lbxR = UBound(v, 1) - LBound(v, 1) + 1 ' first dimension
lbxC = UBound(v, 2) - LBound(v, 2) + 1 ' second dimension
s = ws.Range("A2").Resize(lbxR, lbxC).Address
' set correconding target range
Set rng = ws.Range(s) ' target range
' create short protocol - columns by default differ from user defined ColumnCount property !
Debug.Print String(80, "-")
Debug.Print vbNewLine & "** ListBox1 Defs Data Field Array Dimension **"
Debug.Print " [Target Range " & s & "]"
Debug.Print String(80, "-")
Debug.Print " ListCount = " & ListBox1.ListCount, "rows = " & lbxR & " = ubound(v,1)-lbound(v,1)+1 = " & UBound(v, 1) & " - " & LBound(v, 1) & " + 1 "
Debug.Print " ColumnCount= " & ListBox1.ColumnCount, "cols = " & lbxC & " = ubound(v,2)-lbound(v,2)+1 = " & UBound(v, 2) & " - " & LBound(v, 2) & " + 1 "
Debug.Print String(80, "-")
' ----------------------------------------------------------------
' 3) Work around - correct leading "=", if any occurences presumed
' (avoid error 1004 - App-defined or object-defined error)
' ----------------------------------------------------------------
' ==> Is there an alternative way?
' For i = 0 To R - 1 ' edited thx to D.Lee
' For j = 0 To C - 1
' v(i, j) = IIf(Left(Me.ListBox1.List(i, j) & "", 1) = "=", " ", "") & _
' Me.ListBox1.List(i, j)
' Next j
' Next i
' -------------------------------
' 4) write data back to worksheet
' -------------------------------
rng.value = v
Exit Sub
' =============
' Error Handler
' =============
OOPS:
MsgBox "ERL=" & Erl & " |Error " & Err.Number & "|" & Err.Description & vbNewLine & _
"s=" & s, vbExclamation
End Sub
Tip I recommend reading "Arrays and Ranges in VBA" by C.Pearson
Addendum to OP from Sep 17 '17(alternative solution)
If you know for example that the first target column is text only, you can code the following statement before section [4] instead of searching for each list item starting with =:
rng.Columns(1).NumberFormat = "#"
Lbound(v,1) = 0 ubound(v,1) = r-1
so, it needs to modify i and j.
For i = 0 To R - 1
For j = 0 To C - 1
v(i, j) = IIf(Left(Me.ListBox1.List(i, j) & "", 1) = "=", " ", "") & _
Me.ListBox1.List(i, j)
Next j
Next i
I have a listbox that is multi-select and essentially builds a query. The syntax works as it should, but instead of a line by line entry for each sale how could I check if the array contains the field sale and if it does alter the text to SUM(Sales) As SaleAmt?
This is my current syntax:
Dim I As Long
Dim X As Long
Dim arrValues()
If lstQueryBuild.ListIndex <> -1 Then
For I = 0 To lstQueryBuild.ListCount - 1
If lstQueryBuild.Selected(I) Then
Redim Preserve arrValues(X)
arrValues(X) = lstQueryBuild.List(I)
X = X + 1
End If
Next I
End If
CurrentDb.Exeucte "Select " & Join(arrValues, ",") & " FROM holdingtable"
Which will produce
Debug.Print produces Select name, address, phone, company, sales from holdingtable
you could try substituting your Join() function with a loop through your array.
dim sSQL$
sSQL="Select "
For x=lbound(arrValues) to ubound(arrvalues)
if arrValues(x)="sales" then
sSQL=sSQL & "sum(Sales),"
else
sSQL=sSQL & arrValues(x) & ","
end if
next x
ssQL=left(sSQL,len(ssql)-1) & " from holdingtable"
CurrentDb.Execute sSQL
I have old .mdb database with a lot of tables/forms/queries and external connections (was created in Access 2003) with User Level security.
Now I have decided to move to SQL Server, but I can't decrypt database (in Access 2010 & 2013) to use with Access to SQL tool.
Decryption process is working but in the end I get an error: "you can't access this table".
I've tried repair & compress.
Can you help me?
Thank you.
You don't have a lot of choices as far as I know:
you can reconstruct the .mdw file by creating a new database and using the exact same username and PID of the original user, then use the new .mdw with the old database.
You can use some of the tools from Serge Gavrilov to help you find the username and PID from a database.
Have a look at the forums on UtterAccess.com. There seem to be a lot of discussions regarding lost mdw.
you can use some data repair services like at EverythingAccess. Cost some money, but I'm sure they can recover your data.
Once you can access the DB, you can write code to extract all the forms, queries and such from the DB. Here's a snippet of code I wrote that does this. You're going to need to tweak it heavily, because it's based on a form that allows you to choose the database name. You're going to have to repeat this for queries, forms, etc...
' Database.
Dim dbRep As DAO.Database
Dim dbNew As DAO.Database
' For copying tables and indexes.
Dim tblRep As DAO.TableDef
Dim tblNew As DAO.TableDef
Dim fldRep As DAO.Field
Dim fldNew As DAO.Field
Dim idxRep As DAO.Index
Dim idxNew As DAO.Index
' For copying data.
Dim rstRep As DAO.Recordset
Dim rstNew As DAO.Recordset
Dim rec1 As DAO.Recordset
Dim rec2 As Recordset
Dim intC As Integer
' For copying table relationships.
Dim relRep As DAO.Relation
Dim relNew As DAO.Relation
' For copying queries.
Dim qryRep As DAO.QueryDef
Dim qryNew As DAO.QueryDef
' For copying startup options.
Dim avarSUOpt
Dim strSUOpt As String
Dim varValue
Dim varType
Dim prpRep As DAO.Property
Dim prpNew As DAO.Property
' For importing forms, reports, modules, and macros.
Dim appNew As New Access.Application
Dim doc As DAO.Document
' Open the database, not in exclusive mode.
Set dbRep = OpenDatabase(Forms!CMDB_frmUpgrade.TxtDatabase, False)
' Open the new database
Set dbNew = CurrentDb
DoEvents
' Turn on the hourglass.
DoCmd.Hourglass True
'********************
Debug.Print "Copy Tables"
'********************
If Forms!CMDB_frmUpgrade.CkTables = True Then
Forms!CMDB_frmUpgrade.LstMessages.addItem "Copying Tables:"
' Loop through the collection of table definitions.
For Each tblRep In dbRep.TableDefs
Set rec1 = dbRep.OpenRecordset("SELECT MSysObjects.Name FROM MsysObjects WHERE ([Name] = '" & tblRep.Name & "') AND ((MSysObjects.Type)=4 or (MSysObjects.Type)=6)")
If rec1.EOF Then
XF = 0
Else
XF = 1
End If
' Ignore system tables and CMDB tables.
If InStr(1, tblRep.Name, "MSys", vbTextCompare) = 0 And _
InStr(1, tblRep.Name, "CMDB", vbTextCompare) = 0 And _
XF = 0 Then
'***** Table definition
' Create a table definition with the same name.
Set tblNew = dbNew.CreateTableDef(tblRep.Name)
Forms!CMDB_frmUpgrade.LstMessages.addItem "--> " & tblRep.Name & ""
' Set properties.
tblNew.ValidationRule = tblRep.ValidationRule
tblNew.ValidationText = tblRep.ValidationText
' Loop through the collection of fields in the table.
For Each fldRep In tblRep.Fields
' Ignore replication-related fields:
' Gen_XXX, s_ColLineage, s_Generation, s_GUID, s_Lineage
If InStr(1, fldRep.Name, "s_", vbTextCompare) = 0 And _
InStr(1, fldRep.Name, "Gen_", vbTextCompare) = 0 Then
'***** Field definition
Set fldNew = tblNew.CreateField(fldRep.Name, fldRep.Type, _
fldRep.Size)
' Set properties.
On Error Resume Next
fldNew.Attributes = fldRep.Attributes
fldNew.AllowZeroLength = fldRep.AllowZeroLength
fldNew.DefaultValue = fldRep.DefaultValue
fldNew.Required = fldRep.Required
fldNew.Size = fldRep.Size
' Append the field.
tblNew.Fields.Append fldNew
'On Error GoTo Err_NewShell
End If
Next fldRep
'***** Index definition
' Loop through the collection of indexes.
For Each idxRep In tblRep.Indexes
' Ignore replication-related indexes:
' s_Generation, s_GUID
If InStr(1, idxRep.Name, "s_", vbTextCompare) = 0 Then
' Ignore indices set as part of Relation Objects
If Not idxRep.Foreign Then
' Create an index with the same name.
Set idxNew = tblNew.CreateIndex(idxRep.Name)
' Set properties.
idxNew.Clustered = idxRep.Clustered
idxNew.IgnoreNulls = idxRep.IgnoreNulls
idxNew.Primary = idxRep.Primary
idxNew.Required = idxRep.Required
idxNew.Unique = idxRep.Unique
' Loop through the collection of index fields.
For Each fldRep In idxRep.Fields
' Create an index field with the same name.
Set fldNew = idxNew.CreateField(fldRep.Name)
' Set properties.
fldNew.Attributes = fldRep.Attributes
' Append the index field.
idxNew.Fields.Append fldNew
Next fldRep
' Append the index to the table.
tblNew.Indexes.Append idxNew
End If
End If
Next idxRep
' Append the table.
dbNew.TableDefs.Append tblNew
End If
DoEvents
Next tblRep
'********************
Debug.Print "Copy Data"
'********************
' Loop through the list of table definitions.
For Each tblRep In dbRep.TableDefs
Set rec1 = dbRep.OpenRecordset("SELECT MSysObjects.Name FROM MsysObjects WHERE ([Name] = '" & tblRep.Name & "') AND ((MSysObjects.Type)=4 or (MSysObjects.Type)=6)")
If rec1.EOF Then
XF = 0
Else
XF = 1
End If
' Ignore system tables and CMDB tables.
If InStr(1, tblRep.Name, "MSys", vbTextCompare) = 0 And _
InStr(1, tblRep.Name, "CMDB", vbTextCompare) = 0 And _
XF = 0 Then
' Open a recordset for the new table.
Set rstNew = dbNew.OpenRecordset(tblRep.Name, dbOpenTable)
' Open a recordset for the old table.
Set rstRep = dbRep.OpenRecordset(tblRep.Name, dbOpenTable)
' Continue if there are records.
If Not rstRep.BOF Then
' Move to the first record.
rstRep.MoveFirst
' Loop through all the old table records.
Do Until rstRep.EOF
' Add a record to the new table.
rstNew.AddNew
' For each field in the new table, set the value
' to the value in the related field of the old table.
For intC = 0 To rstNew.Fields.count - 1
rstNew.Fields(intC).Value = _
rstRep.Fields(rstNew.Fields(intC).Name).Value
Next
' Update the new table.
rstNew.Update
' Move to the next old table record.
rstRep.MoveNext
Loop ' rstRep
End If
' Close the new recordset.
rstNew.Close
' Close the old recordset.
rstRep.Close
End If
DoEvents
Next tblRep
End If
I have the following data
Name ID Value
Alice 12C 500
Bob 14 60
Dan 15C 64
Dan 1C 25
Alice 4 556
Bob 11 455
In my data, Alice has both numerical (4) and string+numerical ID (12C) and I want to delete all Alice rows, while I want to hold on to data of names where their ID is strictly numeric (Bob 11, 14) or strictly string+numeric (Dan 15C , 1C).
First I make an array of unique Name entries:
FinalRow = 7
Name_column = 1
n = 1
Dim FID_Array() As Variant
ReDim Preserve FID_Array(1 To 1)
FID_Array(1) = Cells(2, Name_column)
For j = 3 To FinalRow
If Cells(j, Name_column).Value <> FID_Array(n) Then
ReDim Preserve FID_Array(1 To n + 1)
FID_Array(n + 1) = Cells(j, Name_column).Value
n = n + 1
End If
Next j
Then I make an Array of the row numbers that contain a particular Name
ReDim Preserve Count_FID_Array(1 To 1) As Variant
n = 1
range_FID = A2:A7
' In my actual code this is Range_FID
' range_FID = Cells(2, FolderId_column).Address & ":" & Cells(FinalRow, FolderId_column).Address
For Each itm5 In FID_Array()
Count_FID_Array(n) = Application.CountIf(" & range_FID & ", " & itm5 & ")
ReDim Preserve Count_FID_Array(1 To n + 1)
n = n + 1
Next itm5
I don't think my CountIf is working. I have tried to store the value of Count_FID_Array in another cell in a different sheet but I am getting #value!
If I got the countIf to work then I was going to sort the data by name, then double loop to check the ID variable the next "n" times to see if the last digit was "C" for all of them or to check if the ID was numeric for all of them.
Can you please point out why my countif is not working and is there a smarter way to do this?
I am using arrays of names here because in the end I want to feed the array into an autofilter and delete the rows that I don't want.
Update 1 3:45 PM Nov 21 2013: I have solved this as following:
I basically created three columns. First column was 0 or 1 depending on if the the ID was all numbers. The second column was 0 or 1 depending on if the last digit was "C" (in my real work the last two digits are "IB" ) and finally I compared the frequency of these occurences to the frequency of the Name itself. If any of those match then I give it the number 1 else 0. I use this index later to autofilter.
Now I'll try to use zx8754's shorter formula in the VBA code and I will try to address the issues regarding Countif that Joe has raised.
Sub conditionsforsubfolders()
FinalColumn = Cells(1, Columns.Count).End(xlToLeft).Column
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
ActiveWorkbook.ActiveSheet.Columns(FinalColumn + 1).Insert
ActiveWorkbook.ActiveSheet.Columns(FinalColumn + 2).Insert
ActiveWorkbook.ActiveSheet.Columns(FinalColumn + 3).Insert
Isnumber_Column = FinalColumn + 1
Is_IB_Column = FinalColumn + 2
Exceptions_Column = FinalColumn + 3
Cells(1, Isnumber_Column) = "Number"
Cells(1, Is_IB_Column) = "Letters"
Cells(1, Exceptions_Column) = "Exceptions"
For j = 1 To FinalColumn
If Cells(1, j).Value = "TradeId" Then
TradeId_column = j
ElseIf Cells(1, j).Value = "Total Notional per folder" Then
Total_Notional_Per_Folder_Column = j
ElseIf Cells(1, j).Value = "ExternalId" Then
ExternalId_Column = j
ElseIf Cells(1, j).Value = "FolderId" Then
FolderId_column = j
End If
Next j
range_FolderId_fixed = Cells(2, FolderId_column).Address & ":" & Cells(FinalRow, FolderId_column).Address
range_TradeId_fixed = Cells(2, TradeId_column).Address & ":" & Cells(FinalRow, TradeId_column).Address
range_Isnumber = Cells(2, Isnumber_Column).Address & ":" & Cells(FinalRow, Isnumber_Column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_Isnumber_fixed = Cells(2, Isnumber_Column).Address & ":" & Cells(FinalRow, Isnumber_Column).Address
range_Is_IB = Cells(2, Is_IB_Column).Address & ":" & Cells(FinalRow, Is_IB_Column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_Is_IB_fixed = Cells(2, Is_IB_Column).Address & ":" & Cells(FinalRow, Is_IB_Column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_FolderId_cell = Cells(2, FolderId_column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_TradeId_cell = Cells(2, TradeId_column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_Exceptions = Cells(2, Exceptions_Column).Address & ":" & Cells(FinalRow, Exceptions_Column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
Range(range_Isnumber).Formula = "=Isnumber(" & range_TradeId_cell & ")*1"
Range(range_Is_IB).Formula = "=(RIGHT(" & range_TradeId_cell & ",2)= ""IB"")*1"
Range(range_Exceptions).Formula = "=(SUMIF(" & range_FolderId_fixed & "," & range_FolderId_cell & "," & range_Isnumber_fixed & ")= COUNTIF(" & range_FolderId_fixed & "," & range_FolderId_cell & "))*1 +(SUMIF(" & range_FolderId_fixed & "," & range_FolderId_cell & "," & range_Is_IB_fixed & ")= COUNTIF(" & range_FolderId_fixed & "," & range_FolderId_cell & "))*1 "
Worksheets("Sheet1").UsedRange.AutoFilter Field:=7, Criteria1:="=1"
End Sub
Formula solution, no VBA:
=IF(SUMPRODUCT(--($A$2:$A$7=A2),--(ISNUMBER($B$2:$B$7)))=1,"delete","keep")
The problem with your CountIF call is that you're passing a poorly-formed string. You're literally passing "range_FID & ", " & itm5".
First, you set to properly define range_fid:
Dim range_fid As Range
Set range_fid = [A2:A7]
The call CountIF with:
count_fid_array(n) = Application.WorksheetFunction.CountIf(range_fid, itm5)
With that said, I would go about it differently:
Dim c As Range
Dim people As Collection: Set people = New Collection
Dim person As Collection
Dim code As String
For Each c In Range(Range("a2"), Range("a2").End(xlDown)) ' loop through all rows
If IsNumeric(c.Offset(0, 1)) Then ' check if the ID is numeric or not
code = "num"
Else
code = "alphanum"
End If
On Error Resume Next ' Needed in order to avoid error when person already exists in collection
Set person = New Collection
person.Add c.Value, "name"
person.Add code, "code"
people.Add person, c.Value ' will only be added if name doesn't already exist in collection
On Error GoTo 0
If people(c.Value)("code") <> code Then ' if the format (alpha/num) of the ID on the current row is different than the format of a previous row for this name....
people(c.Value).Remove ("code") ' then set the code to "diff"
people(c.Value).Add "diff", "Code"
End If
Next
For Each person In people ' just display the content; you can take appropriate action here
Debug.Print person("name") & ": " & person("code")
Next
The result is a Collection containing names and a code for each. The code will be one of:
num: all values for a name are numeric (Bob)
alphanum: all values for a name are alphanumeric (Dan)
diff: name has at least one each of numeric and alphanumeric (Alice)
Note that this could be done a little clearer with a Dictionary instead of a Collection, or with a Class, but I chose to take the most straightforward approach.
I am having trouble with an asp page that contains a random function to display a random number of random records. The way I have the code now, as shown below, nothing appears on the page even though there are several records that match the criteria.
Out of 500 records I have in my database, about 70 match the criteria, but form some reason, they never seem to fall within the plist variable, to be used in the query.
When I change the max number to a lower number, say 10, I get an error message that the EOF has been found or no more records are available. Using debugging code, I couldnt find anything out of the ordinary, just the fact that from all the 100 records input into the plist, none of them match the records from the main criteria.
I am posting the entire code here. Maybe someone can catch what may be causing to not work properly.
Sub GetRandomDomains
dim conn, maxrecords, count, webname
dim randomrs, sql
'If (conn.State = adStateClosed) Then
OpenDB conn
'End If
count=0
maxrecords=100
KeywordColumnGetRandomKeywords conn, maxrecords, sql
If sql="" then
conn.close
set conn=nothing
Response.Write(" NOT AVAILABLE")
exit sub
end if
set randomrs=conn.execute(sql)
Response.Write("<ul id='catnav'>")
do While Not randomrs.EOF and count<maxrecords
If isnull(randomrs("sitename")) Then
webname=randomrs("domain")
Else
webname=randomrs("sitename")
End if
Response.Write "<li> " & webname &"</li>"
count=count+1
randomrs.movenext
loop
Response.Write("</ul>")
CloseSet randomrs
CloseDB conn
end sub
Sub KeywordColumnGetRandomKeywords (conn,maxrecords,sql)
dim i, id, index, plist, rs, sqlstr, sortstr
plist=""
Set rs=Server.CreateObject("ADODB.Recordset")
sqlstr="SELECT domainid FROM domains"
sqlstr=sqlstr
Debugwrite sqlstr, "sqlstr for random domains"
rs.Open sqlstr,conn,3,3
If rs.eof then
CloseSet rs
Response.Write(" EMPTY")
sql=""
exit sub
end if
Debugwrite rs("domainid"), "rs for random domains"
Dim arrData ' Array to Store Data
Dim arrSequence ' Array to Hold Random Sequence
Dim iArrayLooper ' Integer for Looping
Dim iarraysize ' Size of Data Array
If xdbasetype="Local" Then
iarraysize=cint(rs.recordcount)
else
iarraysize=cint(GetRecordcount (conn))
end if
Debugwrite GetRecordcount(conn), "getrecordcount for random domains array"
Debugwrite(IsArray(iarraysize)), "random domains count array"
'if (cint(GetRecordcount(conn)))= 0 or isnull(cint(GetRecordcount(conn))) then
'Exit Sub
'End if
redim arrdata(cint(iarraysize))
for i = 0 to iarraysize-1
arrData(i)=rs(0)
rs.movenext
next
rs.close
Set rs = Nothing
If iarraysize<maxrecords then
maxrecords=iarraysize
end if
' Get an array of numbers 0 to array size randomly sequenced.
arrSequence = Resequencearray(iArraySize)
for i = 0 to maxrecords-1
index=arrsequence(i)
id=arrdata(index)
if plist<>"" then
plist=plist & ","
end if
plist=plist & id
Next
sql="select domainid, domain, sitename,sitematch,altmatch from domains"
sql = sql & " WHERE restricted=0 and(sitematch like '%" & xsitematch & "%' or altmatch like '%" & xaltmatch & "%')"
sql = sql & " and domainid In (" & plist & ") "
Debugwrite sql, "first sql for random domains"
end sub
Function ResequenceArray(iArraySize)
Dim arrTemp()
Dim I
Dim iLowerBound, iUpperBound
Dim iRndNumber
Dim iTemp
' Set array size
ReDim arrTemp(iArraySize - 1)
Randomize
iLowerBound = LBound(arrTemp)
iUpperBound = UBound(arrTemp)
For I = iLowerBound To iUpperBound
arrTemp(I) = I
Next
' Loop through the array once, swapping each value
' with another in a random location within the array.
For I = iLowerBound to iUpperBound
iRndNumber = Int(Rnd * (iUpperBound - iLowerBound + 1))
' Swap Ith element with iRndNumberth element
iTemp = arrTemp(I)
arrTemp(I) = arrTemp(iRndNumber)
arrTemp(iRndNumber) = iTemp
Next 'I
' Return our array
ResequenceArray = arrTemp
End Function
'***********************************************************************
' get record count for mysql
'************************************************************************
Function GetrecordCount(conn)
dim sqlstr, rs, rcount
sqlstr="select count(domainid) FROM domains WHERE restricted=0 and (domaingroup='" & xdomaingroup & "' or altmatch like '%" & xaltmatch & "%')"
Debugwrite sqlstr, "sqlstr for random domains"
set rs=conn.execute(sqlstr)
if rs.eof then
rcount=0
else
rcount=rs(0)
end if
CloseSet rs
Getrecordcount=cint(rcount)
Debugwrite rcount, "getrecordcount for random domains"
End function
Okay. There may be a far more simple way of approaching this. Here's a piece of code that gets the data as an array - far simpler and we have much more control over what's in it...
'Constants relating to the following routines...
const C_NO_DATA = "NO_DATA" 'Used when no data is returned to a consuming routine
const C_ERROR = "ERROR" 'Used when an error is generated
'GetDataSet
' Returns a table of data based on the supplied SQL statement and connection string.
'Parameters:
' sqlString (string) - The SQL string to be sent.
' connString (string) - The database connection string.
'Usage:
' dataSet = GetDataSet(sqlString, connString)
'Description:
' This function generates a table of information in a 2 dimensional array. The first dimension represents the columns
' and the second the rows. If an error occurs while the routine is executing the array and the base index (0,0) is set
' to C_ERROR, (0,1) to the VBScript error index, and (0,2) to the VBScript error description.
function GetDataSet(sqlString, connString)
'Initialise...
dim returnVal, rsData
on error resume next
'Define and open the recordset object...
set rsData = Server.CreateObject("ADODB.RecordSet")
rsData.Open sqlString, connString, 0, 1, 1
'Initialise an empty value for the containing array...
redim returnVal(0,0)
returnVal(0,0) = C_NO_DATA
'Deal with any errors...
if not rsData.EOF and not rsData.BOF then
'Store the data...
returnVal = rsData.GetRows()
'Tidy up...
rsData.close
set rsData = nothing
select case err.number
case 3021 'No data returned
'Do nothing as the initial value will still exist (C_NO_DATA)
case 0 'No error
'Do nothing as data has been returned
case else
redim returnVal(4,0)
returnVal(0,0) = C_ERROR
returnVal(1,0) = err.number
returnVal(2,0) = err.description
returnVal(3,0) = sqlString
returnVal(4,0) = connString
end select
end if
on error goto 0
'Return the array...
GetDataSet = returnVal
end function
Okay, so we read the data we're after into an array. Note that I don't know where your xaltmatch and xsitematch variables come from so you'll need to supply these at some point...
Dim ds, sql
sql = _
"SELECT " & _
"domainid, " & _
"domain, " & _
"sitename, " & _
"sitematch, " & _
"altmatch " & _
"FROM " & _
"domains " & _
"WHERE " & _
"restricted=0 AND " & _
"(sitematch LIKE '%" & xsitematch & "%' OR " & _
"altmatch LIKE'%" & xaltmatch & "%') AND " & _
"domainid IN (" & plist & ") "
ds = GetDataSet(sql, conn)
The ds variable now contains an array of elements pulled from the database. All we need to do now is loop through the required number of times...
dim row, rows, used, randoms, col, cols, rc, cc
rows = UBound(ds, 2) 'Get the upper bound of the second array dimension
cols = UBound(ds, 1) 'Get the number of columns for writing to the page
randoms = 70 'Total number of randoms we need
used = ","
for rc = 1 to randoms
'Just in case we don't want to repeat the same row...
do
row = int(rnd(1)*rows) 'Zero based - we don't need to add 1
until instr(used, "," & row & ",")) = 0
'Add our random row to the list...
used = used & row & ","
'Write our output to the page...
response.write("<table>")
for cc = 0 to cols
response.write("<tr>")
response.write("<td>")
response.write(ds(cc, row))
response.write("</td>")
response.write("</tr>")
next 'cc
response.write("</table>")
next 'rc
The GetDataSet code is part of my stock functions, so I know that works, but I will hold my hand up and say that I haven't tested the rest of it.
Have a bash with this one, Luis, and let me know how you get on.