+ Reply to Thread
Results 1 to 2 of 2

vba code work in excel 2010 but not excel 365

  1. #1
    Registered User
    Join Date
    12-04-2019
    Location
    USA
    MS-Off Ver
    365
    Posts
    1

    vba code work in excel 2010 but not excel 365

    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


  2. #2
    Registered User
    Join Date
    11-02-2012
    Location
    Western NSW
    MS-Off Ver
    Excel 2003
    Posts
    5

    Re: vba code work in excel 2010 but not excel 365

    Cross Posted at another site !!

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Tags for this Thread

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1