I have a program, that works, I just feel that it is running slower than it should and I feel that it is a bit more unstable than it should be. I am looking for tips on writing "better" code and making my program more stable.
I am looking to better this part of my code for now:
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
'Removes shapes already there that will be updated by the getWeather function
For Each delShape In Shapes
If delShape.Type = msoAutoShape Then delShape.Delete
Next delShape
'Calls a function to get weather data from a web service
Call getWeather("", "Area1")
Call getWeather("", "Area2")
Call getWeather("", "Area3")
'Starting to implement the first connection to a SQL Access database.
Dim cn As Object
Dim rs As Object
'Set cn and sqlConnect as ADODB-objects. Set rs as recordset
Set cn = CreateObject("ADODB.Connection")
Set sqlConnect = New ADODB.Connection
Set rs = CreateObject("ADODB.RecordSet")
'Set sqlConnect as connection string
sqlConnect.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\databases\database.accdb;Persist Security Info=False;"
'Open connection string via connection object
cn.Open sqlConnect
'Set rs.Activeconnection to cn
rs.ActiveConnection = cn
'Get a username from the application to be used further down
Brukernavn = Application.userName
'This part of the code re-arranges the date format from american to european
StartDate = Date
EndDate = Date - 7
midStartDate = Split(StartDate, ".")
midEndDate = Split(EndDate, ".")
StartDate2 = "" & midStartDate(1) & "/" & midStartDate(0) & "/" & midStartDate(2) & ""
EndDate2 = "" & midEndDate(1) & "/" & midEndDate(0) & "/" & midEndDate(2) & ""
'SQL statement to get data from the access database
rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _
"WHERE [Registrert Av] = '" & Brukernavn & "' AND [Loggtype] <> 'Beskjed' AND [Meldt Dato] BETWEEN #" & StartDate2 & "# AND # " & EndDate2 & "#" & _
"ORDER BY [Meldt Dato] DESC;", _
cn, adOpenStatic
'Start to insert data from access database into a list
Dim i As Integer
Dim u As Integer
If Not rs.EOF Then
rs.MoveFirst
End If
i = 0
With lst_SisteFeil
.Clear
Do
If Not rs.EOF Then
.AddItem
If Not IsNull(rs!refnr) Then
.List(i, 0) = rs![refnr]
End If
If IsDate(rs![Meldt Dato]) Then
.List(i, 1) = Format(rs![Meldt Dato], "dd/mm/yy")
End If
.List(i, 4) = rs![nettstasjon]
If Not IsNull(rs![Sekundærstasjon]) Then
.List(i, 2) = rs![Sekundærstasjon]
End If
If Not IsNull(rs![Avgang]) Then
.List(i, 3) = rs![Avgang]
End If
If Not IsNull(rs![Hovedkomponent]) Then
.List(i, 5) = rs![Hovedkomponent]
End If
If Not IsNull(rs![HovedÅrsak]) Then
.List(i, 6) = rs![HovedÅrsak]
End If
If Not IsNull(rs![Status Bestilling]) Then
.List(i, 7) = rs![Status Bestilling]
End If
If Not IsNull(rs![bestilling]) Then
.List(i, 8) = rs![bestilling]
End If
i = i + 1
rs.MoveNext
Else
GoTo endOfFile
End If
Loop Until rs.EOF
End With
endOfFile:
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
'Starts to connect to SQL access database again to get different set of data. This must be possible to make more efficient?
Dim cn2 As Object
Dim rs2 As Object
'Set cn and sqlConnect as ADODB-objects. Set rs as recordset
Set cn2 = CreateObject("ADODB.Connection")
Set sqlConnect2 = New ADODB.Connection
Set rs2 = CreateObject("ADODB.RecordSet")
'Set sqlConnect as connection string
sqlConnect2.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\databases\database.accdb;Persist Security Info=False;"
'Open connection string via connection object
cn2.Open sqlConnect
'Set rs.Activeconnection to cn
rs2.ActiveConnection = cn2
'Second SQL statement
rs2.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _
"WHERE [Registrert Av] <> '" & Brukernavn & "' AND [Meldt Dato] BETWEEN #" & StartDate2 & "# AND # " & EndDate2 & "#" & _
"ORDER BY [Meldt Dato] DESC;", _
cn2, adOpenStatic
'Inserting into second list
If Not rs2.EOF Then
rs2.MoveFirst
End If
u = 0
With lst_AlleFeil
.Clear
Do
If Not rs2.EOF Then
.AddItem
If Not IsNull(rs2!refnr) Then
.List(u, 0) = rs2![refnr]
End If
If IsDate(rs2![Meldt Dato]) Then
.List(u, 1) = Format(rs2![Meldt Dato], "dd/mm/yy")
End If
.List(u, 4) = rs2![nettstasjon]
If Not IsNull(rs2![Sekundærstasjon]) Then
.List(u, 2) = rs2![Sekundærstasjon]
End If
If Not IsNull(rs2![Avgang]) Then
.List(u, 3) = rs2![Avgang]
End If
If Not IsNull(rs2![Hovedkomponent]) Then
.List(u, 5) = rs2![Hovedkomponent]
End If
If Not IsNull(rs2![HovedÅrsak]) Then
.List(u, 6) = rs2![HovedÅrsak]
End If
If Not IsNull(rs2![Status Bestilling]) Then
.List(u, 7) = rs2![Status Bestilling]
End If
If Not IsNull(rs2![bestilling]) Then
.List(u, 8) = rs2![bestilling]
End If
u = u + 1
rs2.MoveNext
Else
GoTo endOfFile2
End If
Loop Until rs2.EOF
End With
endOfFile2:
rs2.Close
cn2.Close
Set rs2 = Nothing
Set cn2 = Nothing
'Starting to connect to the database for the third time
Dim cn3 As Object
Dim rs3 As Object
'Set cn and sqlConnect as ADODB-objects. Set rs as recordset
Set cn3 = CreateObject("ADODB.Connection")
Set sqlConnect3 = New ADODB.Connection
Set rs3 = CreateObject("ADODB.RecordSet")
'Set sqlConnect as connection string
sqlConnect3.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\databases\database.accdb;Persist Security Info=False;"
'Open connection string via connection object
cn3.Open sqlConnect
'Set rs.Activeconnection to cn
rs3.ActiveConnection = cn3
'third sql statement
rs3.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato], [Sekundærstasjon], [Avgang], [Beskrivelse], [Til Dato] FROM [tblDatabase]" & _
"WHERE [Loggtype] = 'Beskjed' AND [Meldt Dato] >= DateAdd('d',-30,Date())" & _
"ORDER BY [Meldt Dato] DESC;", _
cn3, adOpenStatic
'Inserting data in to third list
If Not rs3.EOF Then
rs3.MoveFirst
End If
j = 0
With lst_beskjeder
.Clear
Do
If Not rs3.EOF Then
.AddItem
If Not IsNull(rs3!refnr) Then
.List(j, 0) = rs3![refnr]
End If
If IsDate(rs3![Meldt Dato]) Then
.List(j, 1) = Format(rs3![Meldt Dato], "dd/mm/yy")
End If
.List(j, 4) = rs3![nettstasjon]
If Not IsNull(rs3![Sekundærstasjon]) Then
.List(j, 2) = rs3![Sekundærstasjon]
End If
If Not IsNull(rs3![Avgang]) Then
.List(j, 3) = rs3![Avgang]
End If
If Not IsNull(rs3![beskrivelse]) Then
.List(j, 5) = rs3![beskrivelse]
End If
j = j + 1
rs3.MoveNext
Else
GoTo endOfFile3
End If
Loop Until rs3.EOF
End With
endOfFile3:
rs3.Close
cn3.Close
Set rs3 = Nothing
Set cn3 = Nothing
End Sub
Here is the function I have used to get weather data.
Public Sub getWeather(APIurl As String, sted As String)
Dim i As Integer
i = 0
Dim omraade As String
omraade = ""
omraade = sted
If sted = "Area1" Then
i = 4
ElseIf sted = "Area2" Then
i = 6
ElseIf sted = "Area3" Then
i = 8
End If
Dim WS As Worksheet: Set WS = ActiveSheet
Dim delShape As Shape
Dim city As String
Dim Req As New XMLHTTP
Req.Open "GET", "" & APIurl & "", False
Req.Send
Dim Resp As New DOMDocument
Resp.LoadXML Req.responseText
Dim Weather As IXMLDOMNode
Dim wShape As Shape
Dim thisCell As Range
For Each Weather In Resp.getElementsByTagName("current_condition")
Set thisCell = WS.Range(Cells(2, i), Cells(2, i))
Set wShape = WS.Shapes.AddShape(msoShapeRectangle, thisCell.Left, thisCell.Top, thisCell.Width, thisCell.Height)
wShape.Fill.UserPicture Weather.ChildNodes(4).Text 'img
Cells(3, i).Value = "" & Weather.ChildNodes(7).Text * 0.28 & " m/s" 'windspeedkmph
Cells(4, i).Value = Weather.ChildNodes(9).Text 'Direction
Cells(5, i).Value = Weather.ChildNodes(1).Text & " C" 'observation time
Next Weather
End Sub
Feel free to point out any poor coding and tips on how to improve it. I am currently using the Worksheet Activate sub to activate changes in the tables and get new data, but I suspect that is not the best solution. I am just not sure how else to do it seeing as I want it to be as "automatic" as possible, and use as few buttons to refresh as I can.
Thank you for all the help.
-Thomas
Some tips, but none will affect performance, only help make your code more succinct.
1.
rs.Open "SELECT ..."
If Not rs.EOF Then
rs.MoveFirst
End If
.MoveFirst is unnecessary. After opening a recordset, you are always on the first record, if there are records.
When building complex SQL in VBA, have a look at How to debug dynamic SQL in VBA.
2.
Don't do a Do ... Until loop for recordsets:
Do
If Not rs.EOF Then
' do stuff for each record
' ...
rs.MoveNext
Else
GoTo endOfFile
End If
Loop Until rs.EOF
endOfFile:
rs.Close
Instead use Do While Not rs.EOF :
Do While Not rs.EOF
' do stuff for each record
' ...
rs.MoveNext
Loop
rs.Close
For an empty rs, the loop will not be entered. You don't need the If/Else and the Goto.
I wrote some code today for work and I've ran into an issue where the command I provide the SQL server through VBA doesn't solicit the same quantity of information as if I were to execute the same exact command on the server itself. If I execute the code below in VBA, I get about 25 rows of 68 columns. If I execute the same command on the server itself, I get just over 1500 rows of 68 columns. What I'm doing is selecting either an order number or a date, in a form, and stripping the mountain of data to just what my customer is looking to find. I'm sure this isn't the best way to distribute data across a spreadsheet. I'm looking for suggestions and error corrections!
Thanks in advance,
Adam
Set conn = New ADODB.Connection
Set cmd = New ADODB.Command
constr = "Provider=REMOVEDFORPRIVACY"
If (ComboBox1.Value <> "" And ComboBox2.Value <> "") Or (ComboBox1.Value = "" And ComboBox2.Value = "") Then
MsgBox "Please select one search method.", vbOKOnly
ComboBox2.Value = ""
ComboBox1.Value = ""
ElseIf (ComboBox1.Value <> "" And ComboBox2.Value = "") Then
cmd.CommandText = "SELECT * FROM [Run_Data].[dbo].[RunLog_Data] WHERE SnapShot_Date = '" & ComboBox1.Value & "'"
conn.Open constr
cmd.ActiveConnection = conn
Set rst = cmd.Execute()
Do While Not rst.EOF
o = o + 1
If o > 67 Then
o = 1 'Column Position
n = n + 1 'Row Position
End If
Range(Cells(n, o), Cells(n, o)).Value = rst(o)
rst.MoveNext
Loop
rst.Close
conn.Close
ElseIf (ComboBox1.Value = "" And ComboBox2.Value <> "") Then
cmd.CommandText = "SELECT * FROM [Run_Data].[dbo].[RunLog_Data] WHERE OrderNumber = '" & ComboBox2.Value & "'"
conn.Open constr
cmd.ActiveConnection = conn
Set rst = cmd.Execute()
Do While Not rst.EOF
'Duplicate above and consolidate code
rst.MoveNext
Loop
rst.Close
conn.Close
End If
The issue you are having is that you are performing your rst.MoveNext after you have filled in each cell. Therefore in your first line of output you are picking up the first column of the first record, the second column of the second record, ... the 68th column of the 68th record. Then you are populating the second line of output with the 1st column of the 69th record, etc.
I believe you can replace your entire loop with
Cells(1,1).CopyFromRecordset rst
(replacing the Cells(1,1) with whatever cell you want to be the top-lefthand corner of your results)
but alternatively you could move your rst.MoveNext command inside your If statement, i.e.
If o > 67 Then
o = 1 'Column Position
n = n + 1 'Row Position
rst.MoveNext
End If
Private Sub acceptButton_Click()
Set conn = New ADODB.Connection
Set cmd = New ADODB.Command
constr = "REMOVEDFORPRIVACY"
Dim sel_str, sel_type As String
If (ComboBox1.Value <> "" And ComboBox2.Value <> "") Or (ComboBox1.Value = "" And ComboBox2.Value = "") Then
MsgBox "Please select one search method.", vbOKOnly
ComboBox2.Value = ""
ComboBox1.Value = ""
ElseIf (ComboBox1.Value <> "" And ComboBox2.Value = "") Then
sel_type = "SnapShot_Date"
sel_str = ComboBox1.Value
ElseIf (ComboBox1.Value = "" And ComboBox2.Value <> "") Then
sel_type = "OrderNumber"
sel_str = ComboBox2.Value
End If
cmd.CommandText = "SELECT * FROM [Run_Data].[dbo].[RunLog_Data] WHERE " & sel_type & " = '" & sel_str & "'"
conn.Open constr
cmd.ActiveConnection = conn
Set rst = cmd.Execute()
Cells(2, 1).CopyFromRecordset rst
rst.Close
conn.Close
Me.Hide
End Sub
I have 31 text boxes that get populated with ADO from a Calendar Table as per below function:
Private Function FillDates()
Dim cnn As ADODB.Connection
Dim ssql As String
Dim rst As ADODB.Recordset
Set cnn = CurrentProject.Connection
Dim i As Integer
Dim Records As Integer
ssql = "SELECT RoomAvailabilityId, Availability FROM RoomAvailability WHERE Month(AvailabilityDate)=Month(Now()) AND RoomTypesId=1"
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.Open ssql, cnn
Records = rst.RecordCount
For i = 1 To Records
Me("idtext" & i).Value = rst.Fields!RoomAvailabilityId
Me("Text" & i).Value = rst.Fields!Availability
rst.MoveNext
Next i
rst.Close
Set rst = Nothing
End Function
This is a simplified version of the actual code. The actual code hides the text boxes when a month is made up of 30 days or 29/28 days.
So I have 2 values now stored in my grid made up of the above text boxes.
I now want to update my table field called Availability (Number - Long Integer Datatype) with a button click and I am not able to touch base with this.
Could you please suggest how? This is my starting non working code:
Private Sub cmdUpdatetxt_Click()
Dim cn As ADODB.Connection '* Connection String
Dim oCm As ADODB.Command '* Command Object
Dim iRecAffected As Integer
Set cn = CurrentProject.Connection
Dim i As Integer
For i = 1 To 31
AvailableRooms = Me("txt" & i).Value
AvailableRoomsId = Me("idtext" & i).Value
Next i
Set oCm = New ADODB.Command
oCm.ActiveConnection = cn
oCm.CommandText = "Update RoomAvailability Set Availability ='" & AvailableRooms & "' WHERE RoomAvailabilityId = '" & AvailableRoomsId & "' AND Month(RoomAvailability.AvailabilityDate) = '" & cboMonthYear.Value & "' "
oCm.Execute iRecAffected
If iRecAffected = 0 Then
MsgBox "Nessun Utente Inserito"
End If
If cn.State <> adStateClosed Then
cn.Close
If Not oCm Is Nothing Then Set oCm = Nothing
If Not cn Is Nothing Then Set cn = Nothing
End If
End Sub
Thank you very much in advance
As per Nathan_Sav suggestion, this is the working code:
Private Sub cmdUpdatetxt_Click()
On Error GoTo ErrorTrap
Dim i As Integer
For i = 1 To 31
Dim cn As ADODB.Connection '* Connection String
Dim oCm As ADODB.Command '* Command Object
Dim iRecAffected As Integer
Set cn = CurrentProject.Connection
AvailableRooms = Me("txt" & i).Value
AvailableRoomsId = Me("idtext" & i).Value
Set oCm = New ADODB.Command
oCm.ActiveConnection = cn
oCm.CommandText = "Update RoomAvailability Set Availability =" & AvailableRooms & " WHERE RoomAvailabilityId = " & AvailableRoomsId & " AND Month(RoomAvailability.AvailabilityDate) = '" & cboMonthYear.Value & "' "
oCm.Execute iRecAffected
If iRecAffected = 0 Then
MsgBox "Nessun Utente Inserito"
End If
If cn.State <> adStateClosed Then
cn.Close
If Not oCm Is Nothing Then Set oCm = Nothing
If Not cn Is Nothing Then Set cn = Nothing
End If
Next i
Exit Sub
ErrorTrap:
MsgBox (Err.Description)
End Sub
Have a great day
The code below is programmed to retrieve data from a MS ACCESS 2010 Table and put it into a MS WORD 2010 Form b. The code works fine every time and throws NO error but opens the document and puts the data only every other time.
Sub Module11()
Dim appWord As Word.Application
Dim conn As ADODB.Connection
Dim doc As Word.Document
Dim rst As ADODB.Recordset
Dim tnum As String
Dim sname As String
Dim frst As Integer
Dim mrst As Integer
Dim sam As Integer
Dim strSQL As String
On Error Resume Next
Err.Clear
If Err.Number <> 0 Then
Set appWord = New Word.Application
End If
Set rst = New ADODB.Recordset
Set appWord = GetObject(, "Word.Application")
Set conn = New ADODB.Connection
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= D:\Database\Database.mdb"
rst.Open "tableSDR", conn, adOpenKeyset, adLockOptimistic
tnum = InputBox("Enter the Tracking Number of the Record " & _
"you want to find:", "TRACKING NUMBER")
strSQL = "Select * from table where rst!TrackingNumber='" & tnum & "'"
'AND " _
' & "[rst!TrackingNumber]='" & tnum & "' "
rst.Open strSQL, cn, adOpenDynamic, adLockReadOnly
sam = rst!TrackingNumber
Do While Not rst.EOF
If sam <> tnum Then
rst.MoveNext
sam = rst!TrackingNumber
Else
Exit Do
End If
Loop
Do While rst.EOF
MsgBox "Tracking Number Not Found! "
Exit Sub
Loop
Set doc = appWord.Documents.Open("D:\Database\Form.docx", True)
With doc
.FormFields("model").Result = rst!Model
.FormFields("date_submitted").Result = rst!TDate
.FormFields("part_number").Result = rst!PartNumber
.FormFields("sup_name").Result = rst!SupplierName
.FormFields("part_name").Result = rst!PartName
.FormFields("sup_location").Result = rst!SupplierLocation
.FormFields("rev_level").Result = rst!RevisionLevel
.FormFields("sup_contact").Result = rst!SupplierContact
.FormFields("po_number").Result = rst!PONumber
.FormFields("telephone_num").Result = rst!TelephoneNum
.FormFields("quantity").Result = rst!Quantity
.FormFields("fax_number").Result = rst!FaxNum
.FormFields("required_date").Result = rst!RequiredDate
.FormFields("dev_req").Result = rst!DeviationRequest
.FormFields("dev_period").Result = rst!DeviationPeriod
frst = rst!FirstTime
mrst = rst!MaterialChange
If (frst = 1) Then
If (mrst = 1) Then
doc.FormFields("time").Result = " Material Change and First Time"
ElseIf (msrt = 0) Then
doc.FormFields("time").Result = "First Time"
End If
ElseIf (frst = 0) Then
If (mrst = 1) Then
doc.FormFields("time").Result = " Material Change "
ElseIf (msrt = 0) Then
doc.FormFields("time").Result = "Not Applicable"
End If
End If
.FormFields("cur_spec").Result = rst!CurrentSPecification
.FormFields("prop_dev").Result = rst!ProposedDeviation
.FormFields("reason_dev").Result = rst!ReasonForDeviation
.FormFields("pur_sign").Result = rst!PurchaseSign
.FormFields("pur_des").Result = rst!PurchaseAD
.FormFields("pur_date").Result = rst!PurchaseDate
.FormFields("pur_com").Result = rst!PurchaseComments
.FormFields("qual_sign").Result = rst!QualitySign
.FormFields("qual_des").Result = rst!QualityAD
.FormFields("qual_date").Result = rst!QualityDate
.FormFields("qual_com").Result = rst!QualityComments
.FormFields("engg_sign").Result = rst!EnggSign
.FormFields("engg_des").Result = rst!EnggAD
.FormFields("engg_date").Result = rst!EnggDate
.FormFields("engg_com").Result = rst!EnggComments
.FormFields("manu_sign").Result = rst!ManuSign
.FormFields("manu_des").Result = rst!ManuAD
.FormFields("manu_date").Result = rst!ManuDate
.FormFields("manu_com").Result = rst!ManuComments
.FormFields("other_sign").Result = rst!OtherSign
.FormFields("other_des").Result = rst!OtherAD
.FormFields("other_date").Result = rst!OtherDate
.FormFields("other_com").Result = rst!OtherComments
.FormFields("doc_req").Result = rst!ChangeRequired
.FormFields("pca_number").Result = rst!PCANum
.FormFields("dis_comments").Result = rst!Comments
.FormFields("tracking_num").Result = rst!TrackingNumber
.Visible = True
.Activate
End With
doc.ActiveDocument.SaveAs (MSQname)
doc.Quit
Set doc = Nothing
Set rst = Nothing
Set appWord = Nothing
Set conn = Nothing
Exit Sub
errHandler:
MsgBox Err.Number & ": " & Err.Description
End Sub
I can't see any closure of the connection. The code falling over would cause it to close thus it would work the next time. try rs.close at then end.
I know how to connect excel to mysql manually, which is to click Data tab->From other sources->Data connection wizard...
The data loaded appear in this style. Note that by default the head line has a different background color than the lines below, and the background color of the other lines changes, the border color is white, etc.
I also learned how to import data by vba.
Sub ConnetMySQL()
Set conn = New ADODB.Connection
conn.ConnectionString = "Driver={MySQL ODBC 5.3 Unicode Driver};" & _
"Server = localhost; " & _
"Poer = 3306" & _
"Database = NBA;" & _
"UID = root; PASSWORD = ; OPTION=3"
conn.Open
Set rs = New ADODB.Recordset
strSQL = "SELECT * FROM `nba`.`game`"
rs.Open strSQL, conn
Dim myArray()
myArray = rs.GetRows()
kolumner = UBound(myArray, 1)
rader = UBound(myArray, 2)
For K = 0 To kolumner ' Using For loop data are displayed
Worksheets("Game").Range("a5").Offset(0, K).Value = rs.Fields(K).Name
For R = 0 To rader
Worksheets("Game").Range("A5").Offset(R + 1, K).Value = myArray(K, R)
Next
Next
rs.Close
'MsgBox strOutput
conn.Close
Set conn = Nothing
Set rs = Nothing
End Sub
But the data loaded by vba doesn't have any style.
I believe I must miss something in my code. How should I modify the code so that the data loaded by vba have the same style as the data loaded manually?
The below code will look for 1 table on the active sheet (assuming the ONLY information is the table). It does not matter about the size of the table. It will assume that there are headers. It will then format as your picture is formatted.
Sub test()
Set X = Sheets("Sheet1").UsedRange
ActiveSheet.ListObjects.Add(xlSrcRange, X, , xlYes).Name = _
"Table1"
X.Select
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleMedium9"
End Sub
The below code is untested, but it should work for you:
Sub ConnetMySQL()
Set conn = New ADODB.Connection
conn.ConnectionString = "Driver={MySQL ODBC 5.3 Unicode Driver};" & _
"Server = localhost; " & _
"Poer = 3306" & _
"Database = NBA;" & _
"UID = root; PASSWORD = ; OPTION=3"
conn.Open
Set rs = New ADODB.Recordset
strSQL = "SELECT * FROM `nba`.`game`"
rs.Open strSQL, conn
Dim myArray()
myArray = rs.GetRows()
kolumner = UBound(myArray, 1)
rader = UBound(myArray, 2)
For K = 0 To kolumner ' Using For loop data are displayed
Worksheets("Game").Range("a5").Offset(0, K).Value = rs.Fields(K).Name
For R = 0 To rader
Worksheets("Game").Range("A5").Offset(R + 1, K).Value = myArray(K, R)
Next
Next
Set X = Sheets("Game").UsedRange
Sheets("Game").ListObjects.Add(xlSrcRange, X, , xlYes).Name = _
"Table1"
X.Select
Sheets("Game").ListObjects("Table1").TableStyle = "TableStyleMedium9"
rs.Close
'MsgBox strOutput
conn.Close
Set conn = Nothing
Set rs = Nothing
end sub