VB help - only write autofiltered data to db, not whole worksheet

[RusselJ]

Hi All

The below code writes the data from my worksheet "Claims" to an Access DB.

The worksheet it filtered by an autofilter on column A (Case Handler).

I would be so grateful if someone can suggest how can this code by modified so that it will only write the autofiltered results to the database rather than the whole worksheet.

Sub WriteToDatabase()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited to your files before use
' when using this code in your file you will need to reference "Microsoft DAO 3.6 Object Library" located under "Tools" and "References..."
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim r As Long
Dim FName As String
Dim ConnectStr As String
Dim PrimaryKey As String


Dim strMyPath As String, strDBName As String, strDB As String, strSQL As String
Dim i As Long, n As Long, lastRow As Long, lFieldCount As Long
 FName = "C:\Users\Russel\Documents\Projects\Quindell\Quindell.mdb"
 ConnectStr = _
 "Provider=Microsoft.Jet.OLEDB.4.0;" & _
 "Data Source=" & FName & ";" & _
 "Mode=Share Deny None;"


 cn.Open (ConnectStr)
 ' open the database
 
 ' get all records in a table
 r = 3 ' the start row in the worksheet
 
 
  
 Do Until ActiveWorkbook.Sheets("Claims").Range("N" & r).Value = ""
 ' repeat until first empty cell in column N >
 'change from dbOpenTable to dbOpenDynamic
 With rs
   PrimaryKey = ActiveWorkbook.Sheets("Claims").Range("B" & r).Value
 
   strSQL = "SELECT * " & _
    "FROM `MergedData`" & _
    "WHERE (`MergedData`.`Ref`='" & PrimaryKey & "')"
.Open Source:=strSQL, _
   ActiveConnection:=cn, _
   CursorType:=adOpenDynamic, _
   LockType:=adLockOptimistic, _
   Options:=adCmdText
   
  'if EOF add new record otherwise overwrite old record
  If .EOF = True Then
   .AddNew ' create a new record
  End If


  ' add values to each field in the record
  .Fields("Case Handler") = ActiveWorkbook.Sheets("Claims").Range("A" & r).Value
  .Fields("Ref") = PrimaryKey
  .Fields("Claims Reference Number") = ActiveWorkbook.Sheets("Claims").Range("C" & r).Value
  .Fields("Claimant Name") = ActiveWorkbook.Sheets("Claims").Range("D" & r).Value
  .Fields("Policyholder/ Insured Name") = ActiveWorkbook.Sheets("Claims").Range("E" & r).Value
  .Fields("Industry") = ActiveWorkbook.Sheets("Claims").Range("F" & r).Value
  .Fields("Company Status") = ActiveWorkbook.Sheets("Claims").Range("G" & r).Value
  .Fields("Comments") = ActiveWorkbook.Sheets("Claims").Range("N" & r).Value
    
  
  ' add more fields if necessary...
  .Update ' stores the new record
 End With
 r = r + 1 ' next row
  rs.Close
 Set rs = Nothing
 Loop
 cn.Close
 Set cn = Nothing
End Sub

 

[RusselJ]

Bump