I have this vba code that I was running previously in Excel 2010 on windows 7. In a nutshell the code is creating a new worksheet and is copy and pasting the recordset into the new worksheet. Then the code will do a lookup and insert new data into that same worksheet. Recently, the business updated our office suite to Office 365. After that, everything in the code works up until the bolded. The bolded part of the code does not produce the results in office365. I ran the code line for line in office365 and cannot seem to figure out where the incompatibility is occurring. Can anyone help me figure this out?


Public Sub LinkCycle()

'dual purpose sub: 1) to populate the "Records" column in the exception sheet. 2) to create an exception report to send to sub/ GIS contacts to review.

'this sub is expected to be called from 3 sheets: "Exceptions","Email Report"(R),"SUN ID Report"(R). (R)=create exception report.

Dim errorFlag As Double

Call setGlobal

Dim tbl As ListObject

Dim masterWBNm As String, masterShtNm As String

Set tbl = exceptionTbl

masterWBNm = ThisWorkbook.Name

masterShtNm = ActiveSheet.Name




If masterShtNm <> dashboardShtNm Then

Call OptimizeCode_Begin

End If




Dim colNm_date As String, colNm_rule As String, colNm_subSource As String, colNm_records As String, colNm_release As String

Dim col_date As Integer, col_rule As Integer, col_subSource As Integer, col_records As Integer, col_release As Integer

Dim headerRow As Integer

colNm_date = "True Date"

colNm_rule = "Rule"

colNm_subSource = "Subsidiary or Source System"

colNm_records = "Records"

colNm_release = "Initial Release As Of Date"

col_date = tbl.ListColumns(colNm_date).Range.Column

col_rule = tbl.ListColumns(colNm_rule).Range.Column

col_subSource = tbl.ListColumns(colNm_subSource).Range.Column

col_records = tbl.ListColumns(colNm_records).Range.Column

col_release = tbl.ListColumns(colNm_release).Range.Column




headerRow = tbl.HeaderRowRange.Row




'method explained: we create an array of the unique hyperlinks in the rule column-- that way, we can open each link ONCE instead of once per

'sub/source. in 3 other arrays, we store information PER hyperlink: the rule name, as of date, and the date the rule was implemented (release date).

'in 1 array, we store information PER hyperlink PER row in which the hyperlink occurs: the sub/source and the row index.




Dim cell_selector As Range

Dim rulePath As String

Dim hyperlinkArr() As String, hyperlinkArrSize As Double 'array of hyperlinks

Dim hyperlinkDict As Object 'dictionary with key=hyperlink, value=index of hyperlink in hyperlink array

Dim findIndex As Double 'to retrieve value from dictionary

Dim subSourceArr() As Variant, insertSubSourceArr() As String 'arrary of subs/sources per hyperlink

Dim insertSubSource As String, insertRule As String, insertDate As Date, insertRelease As Date

Dim ruleArr() As Variant, dateArr() As Date, releaseArr() As Date

Dim indexArr() As Variant, insertIndexArr() As Long




hyperlinkArrSize = -1

subSourceArrSize = -1

ruleArrSize = -1

releaseArrSize = -1

Set hyperlinkDict = CreateObject("Scripting.Dictionary")




For Each cell_selector In tbl.ListColumns(col_rule).DataBodyRange.SpecialCells(xlCellTypeVisible)

rulePath = cell_selector.Hyperlinks(1).Address

insertSubSource = tbl.DataBodyRange(cell_selector.Row - headerRow, col_subSource)

insertRule = tbl.DataBodyRange(cell_selector.Row - headerRow, col_rule)

insertDate = tbl.DataBodyRange(cell_selector.Row - headerRow, col_date)

insertRelease = tbl.DataBodyRange(cell_selector.Row - headerRow, col_release)

ReDim insertIndexArr(0)

ReDim insertSubSourceArr(0)

If Not IsInArray(rulePath, hyperlinkArr) Then

pp hyperlinkArrSize



ReDim Preserve hyperlinkArr(hyperlinkArrSize)

hyperlinkArr(hyperlinkArrSize) = rulePath

hyperlinkDict.Add rulePath, hyperlinkArrSize



ReDim Preserve ruleArr(hyperlinkArrSize)

ruleArr(hyperlinkArrSize) = insertRule



ReDim Preserve dateArr(hyperlinkArrSize)

dateArr(hyperlinkArrSize) = insertDate



ReDim Preserve releaseArr(hyperlinkArrSize)

releaseArr(hyperlinkArrSize) = insertRelease



'Arrays that need to be updated for each row

ReDim Preserve indexArr(hyperlinkArrSize)

insertIndexArr(0) = cell_selector.Row - headerRow

indexArr(hyperlinkArrSize) = insertIndexArr



ReDim Preserve subSourceArr(hyperlinkArrSize)

insertSubSourceArr(0) = insertSubSource

subSourceArr(hyperlinkArrSize) = insertSubSourceArr

Else

findIndex = hyperlinkDict(rulePath)

insertIndexArr = indexArr(findIndex)

insertSubSourceArr = subSourceArr(findIndex)

If Not IsInArray(insertSubSource, insertSubSourceArr) Then

ReDim Preserve insertIndexArr(UBound(insertIndexArr) + 1)

insertIndexArr(UBound(insertIndexArr)) = cell_selector.Row - headerRow

indexArr(findIndex) = insertIndexArr



ReDim Preserve insertSubSourceArr(UBound(insertSubSourceArr) + 1)

insertSubSourceArr(UBound(insertSubSourceArr)) = insertSubSource

subSourceArr(findIndex) = insertSubSourceArr

End If

End If

Next cell_selector




Set hyperlinkDict = Nothing

Erase insertSubSourceArr




Dim fillRecordsRng As Range

Set fillRecordsRng = tbl.ListColumns(col_records).DataBodyRange.SpecialCells(xlCellTypeVisible)




Dim loopCounter As Double 'status bar progress

Dim RS As Object, RSFlag As Boolean: Set RS = CreateObject("ADODB.Recordset")

Dim ruleNm As String, ruleShtNm As String, exceptionDate As Date, releaseDate As Date 'info from exception table

Dim fileType As Integer, orgHeader As String, orgFilter As String 'determined from info from exception table

Dim filterRecordCount As Double 'used to populate records column

Dim startRow As Double, fieldCounter As Integer, reportCellSelector As Range 'iterate in reportWB

Dim exceptionRows As Integer, findOrgHeaderCol As Integer 'iterate in exception WB

loopCounter = 0




If masterShtNm <> exceptionShtNm Then 'creates report if called from anywhere except exception sheet

Dim reportWB As Workbook

Set reportWB = Workbooks.Add

End If




For i = 0 To hyperlinkArrSize

rulePath = hyperlinkArr(i)

ruleNm = ruleArr(i)

ruleShtNm = Left(ruleNm, 31)

exceptionDate = dateArr(i)

releaseDate = releaseArr(i)



If Len(ruleNm) < 49 And exceptionDate <> CDate("6/26/2018") Then

'open exception file as recordset

RSFlag = True

Set RS = WSToRS_NoHdr(rulePath)

RS.Open

ElseIf Len(ruleNm) >= 49 And exceptionDate <> CDate("6/26/2018") Then

Dim exceptionWB As Workbook 'open exception file as workbook

RSFlag = False

Workbooks.Open rulePath, ReadOnly:=True

Set exceptionWB = ActiveWorkbook

End If



For j = 0 To UBound(subSourceArr(i))

pp loopCounter

Application.StatusBar = "Progress: " & loopCounter & "/" & tbl.ListColumns(col_rule).DataBodyRange.SpecialCells(xlCellTypeVisible).Count

orgFilter = subSourceArr(i)(j)

fileType = fileTypeDetermine(ruleNm, exceptionDate, releaseDate, orgHeader)



If orgFilter = "DDA" And ruleNm = "IDL_007_TransferAmount_1" Then

orgFilter = "NY"

End If



If masterShtNm <> exceptionShtNm Then

If RSFlag And exceptionDate <> CDate("6/26/2018") Then 'populate report using recordset

With reportWB

reportWB.Activate

If Evaluate("ISREF('" & ruleShtNm & "'!A1)") Then

'if sheets already exists, paste data starting at appropriate row

startRow = .Sheets(ruleShtNm).UsedRange.Rows.Count + 1

Else

.Sheets.Add().Name = ruleShtNm

For fieldCounter = 0 To RS.Fields.Count - 1 'add header

.Sheets(ruleShtNm).Cells(1, fieldCounter + 1) = RS.Fields(fieldCounter).Name

Next fieldCounter

startRow = 2

End If

RS.Filter = orgHeader & " = '" & orgFilter & "'"

.Sheets(ruleShtNm).Cells(startRow, 1).CopyFromRecordset RS



.Sheets(ruleShtNm).Select

Range(.Sheets(ruleShtNm).Cells(startRow, 1), .Sheets(ruleShtNm).Cells(startRow, RS.Fields.Count)).Select

If RS.RecordCount > 1 Then

Range(Selection, Selection.End(xlDown)).Select

End If



For Each reportCellSelector In Selection 'recordset loses formatting, need to account for this

reportCellSelector.Value = reportCellSelector.Value

Next reportCellSelector

End With



filterRecordCount = RS.RecordCount



ElseIf Not RSFlag And exceptionDate <> CDate("6/26/2018") Then 'populate report using workbooks.open. exception ws will be the active sheet

ActiveSheet.Cells(1, 1).AutoFilter Field:=ActiveSheet.Range("A1:AA1").Find(orgHeader).Column, Criteria1:=orgFilter

exceptionRows = WorksheetFunction.CountA(ActiveSheet.Columns(1))

exceptionCols = WorksheetFunction.CountA(ActiveSheet.Rows(1))

Range(Cells(1, 1), Cells(exceptionRows, exceptionCols)).SpecialCells(xlCellTypeVisible).Select

filterRecordCount = Selection.Rows.Count - 1

Selection.Copy



With reportWB

.Activate

If Evaluate("ISREF('" & ruleShtNm & "'!A1)") Then 'if sheets already exists, paste data starting at appropriate row

startRow = .Sheets(ruleShtNm).UsedRange.Rows.Count + 1

.Sheets(ruleShtNm).Paste Destination:=.Sheets(ruleShtNm).Cells(startRow, 1)

.Sheets(ruleShtNm).Rows(startRow).Delete

Else

.Sheets.Add().Name = ruleShtNm

startRow = 1

.Sheets(ruleShtNm).Paste Destination:=.Sheets(ruleShtNm).Cells(startRow, 1)

End If

End With

End If

Else 'only need to populate records if called from exceptions sheet

If RSFlag And exceptionDate <> CDate("6/26/2018") Then

RS.Filter = orgHeader & " = '" & orgFilter & "'"

filterRecordCount = RS.RecordCount

ElseIf Not RSFlag And exceptionDate <> CDate("6/26/2018") Then

findOrgHeaderCol = ActiveSheet.Range("A1:AA1").Find(orgHeader).Column

ActiveSheet.Cells(1, 1).AutoFilter Field:=findOrgHeaderCol, Criteria1:=orgFilter

exceptionRows = WorksheetFunction.CountA(ActiveSheet.Columns(1))



'filterrecordcount for workbooks open method assumes that org field is populated for all records

filterRecordCount = Range(ActiveSheet.Cells(1, findOrgHeaderCol), ActiveSheet.Cells(exceptionRows, findOrgHeaderCol)).SpecialCells(xlCellTypeVisible).Count - 1

End If



tbl.DataBodyRange(indexArr(i)(j), col_records) = filterRecordCount

End If

Next j

If RSFlag And exceptionDate <> CDate("6/26/2018") Then

RS.Close

ElseIf Not RSFlag And exceptionDate <> CDate("6/26/2018") Then

Application.DisplayAlerts = False

exceptionWB.Close savechanges:=False

Application.DisplayAlerts = True

End If

Next i




Set RS = Nothing




If masterShtNm <> exceptionShtNm And masterShtNm <> dashboardShtNm Then
Dim rCol_ruleNm As Integer, rCol_ruleCondition As Integer
Dim findRuleRow As Integer, findRuleCondition As String
rCol_ruleNm = ruleTbl.ListColumns("Rule Name").Range.Column
rCol_ruleCondition = ruleTbl.ListColumns("DQ Business Rule/Condition").Range.Column

'formatting
For k = 1 To reportWB.Sheets.Count - 3
With reportWB.Sheets(k)
.Cells.EntireColumn.AutoFit
.Rows("1:5").Insert
.Cells(1, 1) = "DQ Rule:"
findRuleRow = Application.WorksheetFunction.Match("*" & Sheets(k).Name & "*", ruleTbl.ListColumns(rCol_ruleNm).DataBodyRange, 0)
findRuleCondition = CStr(ruleTbl.DataBodyRange(findRuleRow, rCol_ruleCondition))
.Cells(1, 2) = findRuleCondition
.Cells(3, 1) = "Fields:"
.Cells(4, 1).AutoFilter
.Select
End With
'freeze panes
With ActiveWindow
.SplitColumn = 0
.SplitRow = 4
.FreezePanes = True
End With
Next k
End With

'dummy sheets
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
Application.DisplayAlerts = True
'return to first sheet
Sheets(1).Select

End If

If masterShtNm <> dashboardShtNm Then
Call OptimizeCode_End
End If
End Sub