Import Excel data based on cell attribute into Access

[wgbrow43]

I have an Excel workbook with multiple worksheets.
The third worksheet:
1) Is titled "Priority Codes"
2) Contains data in columns "A" & "B" - number of rows is unknown
3) Some of the cells are in "BOLD" type

I want to import the data in column "A" if it is in "BOLD" into an access table called "tblPriorityPriorityCodes". I have the VBA code to import all of the data in column "A" if it is the only worksheet in the workbook but I don't know how to address the cells in a multi-worksheet workbook, nor do I know how to test if the cell's "BOLD" attribute is true.

I've searched the forums and FAQ's but didnt' see this topic discussed. Any help will be greatly appreciated!

Here's my code:


Private Sub cmdReadProjectCodes_Click()
Dim a, w, WSN As Object
Dim filename, strContinue As String
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim intRow As Integer

filename = "d:\Project Code Priorities.xls"

Set a = CreateObject("Excel.Application&quot
Set w = a.Workbooks.Add(filename)
Set WSN = w.Worksheets(1)
WSN.Activate

Set db = CurrentDb
Set rs1 = db.OpenRecordset("tblPriorityProjectCodes", dbOpenDynaset)

'Delete existing records in tblPriorityProjectCodes
DoCmd.OpenQuery ("qdelPriorityProjectCodes&quot

' data in spreadsheet starts on line 2 (line 1 is fieldname)
strContinue = "Y"
intRow = 2

Do While strContinue = "Y"
If Len(Trim(w.activesheet.cells(intRow, 1))) > 0 Then
rs1.AddNew
rs1![project code] = w.activesheet.cells(intRow, 1)
rs1.Update
intRow = intRow + 1
Else
strContinue = "N"
Exit Do
End If
Loop
rs1.Close
w.Close

Set rs1 = Nothing
Set a = Nothing
Set w = Nothing
Set WSN = Nothing

End Sub

 

[wgbrow43]

I'll reply to my own post - I found the answer at

http://www.forumco.com/jmhare/topic...tle=nasty+excel&Forum_Title=General+Questions

Here's their sample code:

Sub sCopyRSExample()
'Copy records to first 20000 rows
'in an existing Excel Workbook and worksheet
'
Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim intLastCol As Integer
Const conMAX_ROWS = 20000
Const conSHT_NAME = "Feature"
Const conWKB_NAME = "c:\my documents\Microsoft Access\testing.xls"
Set db = CurrentDb
Set objXL = New Excel.Application
Set rs = db.OpenRecordset("Customers", dbOpenSnapshot)
With objXL
.Visible = True
Set objWkb = .Workbooks.Open(conWKB_NAME)
On Error Resume Next
Set objSht = objWkb.Worksheets(conSHT_NAME)
If Not Err.Number = 0 Then
Set objSht = objWkb.Worksheets.Add
objSht.Name = conSHT_NAME
End If
Err.Clear
On Error GoTo 0
intLastCol = objSht.UsedRange.Columns.Count
With objSht
.Range(.Cells(1, 1), .Cells(conMAX_ROWS, _
intLastCol)).ClearContents
.Range(.Cells(1, 1), _
.Cells(1, rs.Fields.Count)).Font.Bold = True
.Range("A2&quot.CopyFromRecordset rs
End With
End With
Set objSht = Nothing
Set objWkb = Nothing
Set objXL = Nothing
Set rs = Nothing
Set db = Nothing
End Sub

 

[BillPower]

This should do it for you:
Dim a, w As Object
Dim filename, strContinue As String
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim intRow As Integer

filename = "d:\Project Code Priorities.xls"

Set a = CreateObject("Excel.Application&quot
Set w = a.Workbooks.Add(filename)

w.Worksheets("Priority Codes&quot.Select

Set db = CurrentDb
Set rs1 = db.OpenRecordset("tblPriorityProjectCodes", dbOpenDynaset)

'Delete existing records in tblPriorityProjectCodes
DoCmd.OpenQuery ("qdelPriorityProjectCodes&quot

' data in spreadsheet starts on line 2 (line 1 is fieldname)
strContinue = "Y"
intRow = 2

Do While strContinue = "Y"
If Len(Trim(w.activesheet.cells(intRow, 1))) > 0 Then
If w.activesheet.cells(intRow, 1).Font.Bold = True Then
rs1.AddNew
rs1![project code] = w.activesheet.cells(intRow, 1)
rs1.Update
End If
intRow = intRow + 1
Else
strContinue = "N"
Exit Do
End If
Loop
rs1.Close
w.Close

Set rs1 = Nothing
Set a = Nothing
Set w = Nothing

I took out the WSN object. Don't think you need it.

Bill