Vagrant718
New Member
- Joined
- Dec 4, 2019
- Messages
- 2
- Office Version
- 365
- Platform
- Windows
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?
Rich (BB code):
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
Last edited by a moderator:
