Public Sub ScrapeData()
Dim rstData As ADODB.Recordset, rstMeasureID As ADODB.Recordset, rstMeasures As ADODB.Recordset
Dim strMeasureText As String
Dim lngCountDates As Long, lngCountDone As Long, strRange As String
Dim strType As String, strSheetType As String, blnNoMonth As Boolean
Dim strFileName As String
Dim frm As Form
Dim strRepFileName As String
Dim strCenterID As String
Dim xlApp As Excel.Application
Dim strWB as Excel.Workbook
' initializes Excel
Set xlApp = New Excel.Application
' makes the workbook visible
xlApp.Visible = True
' initializes the counter
intCount = 0
' loop until the counter equals the items in the list
Do Until frmAggMain.lst1.ListCount = 0
' sets the variable to the workbook path and name
strWB = frmAggMain.lst1.List(0)
' opens the workbooks listed in the listbox
blnErr = False
Set xlWB = xlApp.Workbooks.Open(strWB)
' WORKBOOK OPENS UP
' opens the POF tab
xlApp.Worksheets("POF").Visible = True
xlApp.Worksheets("POF").Select
' opens recordset to write to
OpenDbConn
Set rstData = New ADODB.Recordset
rstData.Open "tblSpreadsheetOrgNames", cnnCurrent, adOpenDynamic, adLockOptimistic
xlApp.Worksheets("POF").Range("A1").Select
strCenterName = xlApp.Worksheets("POF").Range("A1")
If strCenterName = "" Then
MsgBox "Center Name missing from spreadsheet on " & vbCrLf & _
strWB, vbCritical, "Missing Center Name"
Exit Sub
Else
If FindCenter(strCenterName) = 0 Then
MsgBox "No center found -- canceling operation!", vbCritical, "CENTER NOT FOUND"
Exit Sub
End If
End If
OpenDbConn
xlApp.Worksheets("POF").Range("A4").Select
'ActiveSheet.Range("A4").Select
frmAggMain.SetFocus
lngCountDates = 0
' finds the number of possible date values to check
Do Until ActiveCell.Value > CDate(strDate2GoTo) Or ActiveCell.Value = ""
lngCountDates = lngCountDates + 1
ActiveCell.Offset(1, 0).Select
Loop
lngCountDone = 4
Do Until lngCountDone = lngCountDates + 4
strRange = "A" & lngCountDone
ActiveSheet.Range(strRange).Select
dteDataDate = ActiveCell.Value
strDate = dteDataDate
strAddress = ActiveCell.Address
arrAddress = Split(strAddress, "$", , vbTextCompare)
strCol = arrAddress(1)
intRow = arrAddress(2)
ActiveSheet.Range("B2").Select
strAddress = ActiveCell.Address
arrAddress = Split(strAddress, "$", , vbTextCompare)
strCol2 = arrAddress(1)
Set rstMeasureID = New ADODB.Recordset
Set rstMeasures = New ADODB.Recordset
strSQL = "SELECT tbl_measures.measure_association, spreadsheet_text From tbl_measures"
rstMeasureID.Open strSQL, cnnCurrent, adOpenDynamic, adLockOptimistic
rstMeasures.Open "tbl_measure_data", cnnCurrent, adOpenDynamic, adLockOptimistic
Do Until ActiveCell.Column = 54
ActiveSheet.Range(strCol2 & "2").Select
strMeasureText = Trim(ActiveCell.Text)
rstMeasureID.MoveFirst
Do Until rstMeasureID(1) = strMeasureText
rstMeasureID.MoveNext
If rstMeasureID.EOF Then
Exit Do
End If
Loop
ActiveSheet.Range(strCol2 & CStr(intRow)).Select
If ActiveCell.ColumnWidth <> 0 Then
If ActiveCell.Text <> "" Then
If Selection.Interior.ColorIndex <> xlNone Then
With rstMeasures
.AddNew
.Fields("site_id") = lngCenterID
.Fields("measure_date") = CDate(strDate)
.Fields("measure_id") = rstMeasureID(0)
.Fields("collab_id") = lngCollabID
If IsNumeric(ActiveCell.Text) Then
.Fields("measure_data") = ActiveCell.Text
Else
End If
End If
.Fields("measure_type") = "POF"
.Fields("date_stamp") = Format(Now, "mm/dd/yyyy")
.Fields("time_stamp") = Format(Now, "hh:nn:ss")
.Fields("user_stamp") = strUserName
.Update
End With
End If
End If
End If
ActiveCell.Offset(0, 1).Select
strAddress = ActiveCell.Address
arrAddress = Split(strAddress, "$", , vbTextCompare)
strCol2 = arrAddress(1)
frmAggMain.Refresh
Loop
lngCountDone = lngCountDone + 1
Loop
ActiveSheet.Range(strCol2 & CStr(intRow)).Select
If ActiveCell.Text <> "" Then
If Selection.Interior.ColorIndex <> xlNone Then
With rstMeasures
.AddNew
.Fields("site_id") = lngCenterID
.Fields("measure_date") = CDate(strDate)
.Fields("measure_id") = rstMeasureID(0)
If IsNumeric(ActiveCell.Text) Then
.Fields("measure_data") = ActiveCell.Text
.Fields("collab_id") = lngCollabID
End If
End If
.Fields("measure_type") = "POS"
.Fields("date_stamp") = Format(Now, "mm/dd/yyyy")
.Fields("time_stamp") = Format(Now, "hh:nn:ss")
.Fields("user_stamp") = strUserName
.Update
End With
End If
End If
ActiveCell.Offset(0, 1).Select
strAddress = ActiveCell.Address
arrAddress = Split(strAddress, "$", , vbTextCompare)
strCol2 = arrAddress(1)
Loop
lngCountDone = lngCountDone + 1
Loop
frmAggMain.lst1.Refresh
intCount = intCount + 1
xlWB.Close False
Loop
frmAggMain.lst1.Clear
xlApp.Quit
rstMeasures.Close
rstMeasureID.Close
Set xlApp = Nothing
Set rstMeasures = Nothing
Set rstMeasureID = Nothing
End If
End If
Exit Sub
