Sub PullFromAccess()
Dim LstObject As ListObject
Dim strPath, sqlString, ConnectionString As String
Dim rs, conn As Object
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.RecordSet")
Dim rCell, RngSource As Range
Dim CounterEvery2 As Integer
Dim CustomerVar, CustomerClause As String
CustomerVar = Worksheets("Customer Information").Cells(2, 6).Value
Set wksConf = Worksheets("Configuration Model")
strPath = "E:\Makro\Database Integration\Changing Relationships\Model Excel-Database Relationships v32.accdb"
Set RngSource = Sheets("Queries Source").ListObjects("t_rngsource").ListColumns("TableName").DataBodyRange
ConnectionString = "Provider = Microsoft.ACE.OLEDB.12.0; data source=" & strPath
conn.Open ConnectionString
wksConf.UsedRange.Clear
CustomerClause = " WHERE CustomerName='" & CustomerVar & "'"
lRow = 1
For Each rCell In RngSource
''Added specific customer condition
If rCell.Offset(0, 2) = "Yes" And InStr(1, rCell.Offset(0, 1), "yC_") > 1 Then
sqlString = Replace(rCell.Offset(0, 1), "yC_", "y" & CustomerVar & "_")
ElseIf rCell.Offset(0, 2) = "Yes" Then
sqlString = rCell.Offset(0, 1) & CustomerClause
Else
sqlString = rCell.Offset(0, 1)
End If
With wksConf
CounterEvery2 = CounterEvery2 + 1
Set rs = conn.Execute(sqlString)
Set LstObject = .ListObjects.Add(SourceType:=xlSrcQuery, Source:=rs, _
Destination:=.Cells(lRow, 1))
LstObject.Name = rCell
LstObject.QueryTable.Refresh BackgroundQuery:=False
If Not CounterEvery2 Mod 2 = 1 Then
LstObject.TableStyle = "TableStyleMedium3"
End If
lRow = lRow + LstObject.Range.Rows.Count + 1
Set rs = Nothing
LstObject.Unlink
Set LstObject = Nothing
End With
Next rCell
MsgBox "macro done!"
End Sub
try code similar like here to connect to database.
Bookmarks