Read Table Data from SAP into Excel Using RFCs

Jimbo's picture

Data FlowThe ability to put into the hands of users an easy way to tease out of SAP data directly from tables has always been difficult in larger organizations because BASIS teams tend to disable SQ00 "because performance". Considering that larger organizations have dozens of front end servers and a query will consume a tiny percentage of one front end server's capacity for some seconds leads many to believe that the purpose of blocking this access is to eliminate support calls; eliminating a feature is easier than walking a user through creating a dataset and building a query.

In scenarios where the source tables are less than one million records long and the data can be knit together using vlookups, Excel can be used to tease data out of SAP using the RFC_READ_TABLE function. Where the data exceeds one million records, the preferred method is to use a similar function in Access and articles explaining that capacity are listed here.

The VBA code is relatively simple in this case. The connection to the SAP system has been moved outside into its own function and then each call to the next function recycles the same R3 connection.

Function GetR3(ByRef R3 As Object) As Boolean
    Set R3 = CreateObject("SAP.Functions")
    '*************************************
    '  Put in your own credentials here.
    '*************************************
    R3.Connection.System = "P01"
    R3.Connection.SystemNumber = "00"
    R3.Connection.client = "100"
    R3.Connection.User = ""  ' Put your User ID here if desired.
    R3.Connection.Password = "" 'Put your password here (optional).
    R3.Connection.LANGUAGE = "EN"
    R3.Connection.ApplicationServer = "server-name.domain.int" 'Or IP address
       
    If R3.Connection.logon(0, True) <> True Then
       If R3.Connection.logon(0, False) <> True Then
            GetR3 = False
            Exit Function
       End If
    End If
    GetR3 = True
End Function

Next, the function uses the R3 Connection to create a function object that is then used to tease out the data requested. The parameters passed in are the R3 Connector, the table in SAP, the tab name to be created (or replaced), the list of desired fields separated by comma and finally the options that will be discussed below.

Function SAP_RFC_READ_TABLE(ByRef R3 As Object, strSAPTable As String, strTabName As String, strFields As String, Optional ByVal strOptions As String = "") As Long

    Dim strTemp As String
    SAP_RFC_READ_TABLE = 0
    
    'Create the database parallel to SAP's . . .
    Dim nCounter As Long, nCurrent As Long
    Dim nFieldData(999, 2) As Long, strSaveOptions As String
    Dim strRow As String
    Dim strFieldnames() As String
    Dim strConvOptions() As String
    Dim FinalRFCQuery As String
    Dim vField As Variant
    Dim j As Integer
    Dim SQL As String
    Dim nCurRec As Long, nCurSec As Long
    Dim isUpdate As Boolean
    Dim strFieldName As String
    Dim nRowCount As Long
    Dim nTotalRecords As Long

    Dim RetVal As Variant, nSecondsLeft As Long, nTotalSeconds As Long
    Dim MyFunc, App As Object

    ' Define the objects to hold IMPORT parameters
    Dim QUERY_TABLE As Object
    Dim DELIMITER   As Object
    Dim NO_DATA     As Object
    Dim ROWSKIPS    As Object
    Dim ROWCOUNT    As Object
    
    ' Define the objects to hold the EXPORT parameters
    ' None for RFC_TABLE_READ

    ' Define the objects to hold the TABLES parameters
    ' Where clause
    Dim OPTIONS As Object
    ' Fill with fields to return.  After function call will hold
    ' detailed information about the columns of data (start position
    ' of each field, length, etc.
    Dim FIELDS  As Object
    ' Holds the data returned by the function
    Dim DATA    As Object
    
    ' Use to write out results
    Dim ROW As Object
    
    Dim Result As Boolean
    Dim iRow, iColumn, iStart, iStartRow, iField, iLength As Integer
    
    
    '***********************************
    ' Set up an offset and length loop.
    '***********************************
    Const nMaxRowCount = 250000
    Dim nRowSkip
    nRowSkip = 0
    

    nTotalSeconds = 0


    '*****************************************************
    'Call RFC function RFC_READ_TABLE
    '*****************************************************
    Set MyFunc = R3.Add("RFC_READ_TABLE")

    ' Set the Objects to the parameter they will return
    Set QUERY_TABLE = MyFunc.exports("QUERY_TABLE")
    Set DELIMITER = MyFunc.exports("DELIMITER")
    Set NO_DATA = MyFunc.exports("NO_DATA")
    Set ROWSKIPS = MyFunc.exports("ROWSKIPS")
    Set ROWCOUNT = MyFunc.exports("ROWCOUNT")

    Set OPTIONS = MyFunc.Tables("OPTIONS")
    OPTIONS.Rows.RemoveAll
    Set FIELDS = MyFunc.Tables("FIELDS")
    FIELDS.Rows.RemoveAll

    QUERY_TABLE.Value = strSAPTable
    DELIMITER.Value = vbTab
    NO_DATA = ""
    ROWSKIPS.Value = nRowSkip
    ROWCOUNT.Value = nMaxRowCount
    
    'Quebrando o nome dos campos
    j = 0
    strFieldnames = Split(strFields, ",")
    For Each vField In strFieldnames
        j = j + 1
        FIELDS.Rows.Add
        FIELDS.Value(j, "FIELDNAME") = Trim(UCase(vField))
    Next
    
    'Quebrando Lendo condições Where
    j = 0
    If strOptions <> "" Then
        stroption = UCase(strOptions)
        'If InStr(strOptions, " OR ") Then
        '    strConvOptions = Split(strOptions, " OR ")
        Do While Len(strOptions) > 0
            For nCurrent = 1 To Len(strOptions)
                'OPTIONS.Value(j, 1) = OPTIONS.Value(j, 1) & Left(strOptions, 1)
                'strOptions = Mid(strOptions, 2, 9999)
                'If Right(OPTIONS.Value(j, 1), 4) = " OR " Or Right(OPTIONS.Value(j, 1), 5) = " AND " Then
                If Right(Left(strOptions, nCurrent), 4) = " OR " Or Right(Left(strOptions, nCurrent), 5) = " AND " Then
                    'Break the option here and start a new one.
                    OPTIONS.Rows.Add
                    j = j + 1
                    OPTIONS.Value(j, 1) = Left(strOptions, nCurrent)
                    strOptions = Mid(strOptions, nCurrent + 1, 9999)
                    Exit For
                Else
                    If nCurrent = Len(strOptions) Then
                        'This is the last Option.
                        OPTIONS.Rows.Add
                        j = j + 1
                        OPTIONS.Value(j, 1) = strOptions
                        strOptions = ""
                    End If
                End If
            Next
        Loop
    End If

    RetVal = DoEvents
    Result = MyFunc.Call

    If Result = True Then
        Set DATA = MyFunc.Tables("DATA")
        Set FIELDS = MyFunc.Tables("FIELDS")
        Set OPTIONS = MyFunc.Tables("OPTIONS")
    Else
        MsgBox MyFunc.EXCEPTION
        'R3.Connection.logoff
        Exit Function
    End If

    nTotalColumns = FIELDS.ROWCOUNT
    
    For iField = 1 To FIELDS.ROWCOUNT
        nFieldData(iField, 1) = FIELDS(iField, "OFFSET")
        nFieldData(iField, 2) = FIELDS(iField, "LENGTH")
    Next

    'Create the requested Tab.
    Dim wsOutput As Worksheet
    Set wsOutput = CreateTab(strTabName)
    Dim nCurrentRow As Long
    Dim strColumn As String, strCell As String, strRange As String
    
    'Freeze the top row...
    Application.ScreenUpdating = True
    ActiveWindow.FreezePanes = False
    ActiveWindow.SplitColumn = 0
    ActiveWindow.SplitRow = 1
    ActiveWindow.FreezePanes = True

    iField = 1
    nRowCount = FIELDS.ROWCOUNT
    strFields = "X"
    For iField = 1 To nRowCount
        nFieldData(iField, 1) = FIELDS(iField, "OFFSET")
        nFieldData(iField, 2) = FIELDS(iField, "LENGTH")
        If iField > 1 Then
            strFields = strFields & ",X"
        End If
    Next
    Dim strFieldValues() As String 'Used later to speed up writes to ranges.
    strFieldValues = Split(strFields, ",")
    
    Do While DATA.ROWCOUNT > 0
    
        For iRow = 1 To DATA.ROWCOUNT
            If nTotalRecords < 1048575 Then
                nTotalRecords = nTotalRecords + 1
        
                strRow = DATA(iRow, 1) 'Pull this into a string rather than pull it from DATA each time...
                
                'Add the row to the spreadsheet.
                For iField = 1 To nRowCount
                    'wsOutput.Range(strCell).NumberFormat = "@" 'Format the cell as text.
                    'wsOutput.Range(strCell).Value = Trim(Mid(strRow, nFieldData(iField, 1) + 1, nFieldData(iField, 2)))
                    strFieldValues(iField - 1) = Trim(Mid(strRow, nFieldData(iField, 1) + 1, nFieldData(iField, 2)))
                Next
                If nRowCount < 27 Then
                    strColumn = Chr(64 + nRowCount)
                Else
                    strColumn = Chr(64 + Int(nRowCount / 26)) & Chr(64 + nRowCount - (26 * (Int(nRowCount / 26))))
                End If
                strCell = strColumn & Trim(1 + nTotalRecords)
                strRange = "A" & Trim(1 + nTotalRecords) & ":" & strCell
                wsOutput.Range(strRange).NumberFormat = "@" 'Format the cell as text.
                wsOutput.Range(strRange).Value = strFieldValues 'Trim(Mid(strRow, nFieldData(iField, 1) + 1, nFieldData(iField, 2)))
            
                If Second(Now()) <> nCurSec Then ' And nCurRec <> rs.RecordCount Then
                    nCurSec = Second(Now())
                    wsOutput.Range("A1").Value = nTotalRecords & " records"
                    If nCurSec / 2 = Int(nCurSec / 2) Then
                        wsOutput.Range("A1").Interior.Color = RGB(255, 255, 0)
                    Else
                        wsOutput.Range("A1").Interior.Color = RGB(233, 233, 0)
                    End If
                    RetVal = DoEvents()
                End If
            End If
            
        Next
        
        '***********************************************************
        ' Check to see if the function should be called again . . .
        '***********************************************************
        If DATA.ROWCOUNT < nMaxRowCount Then
            'There is no need to read again to get a zero value.
            Exit Do
        Else
            'Set the offset to read the next block.
            nRowSkip = nRowSkip + nMaxRowCount
        End If
        
        '***********************************************************
        ' Call the function again to get the next block of records.
        '***********************************************************
        ROWSKIPS.Value = nRowSkip
        ROWCOUNT.Value = nMaxRowCount
        MyFunc.Tables("DATA").Rows.RemoveAll 'Special thanks to Mike Burnett
        Result = MyFunc.Call
        Set DATA = MyFunc.Tables("DATA")
        Set FIELDS = MyFunc.Tables("FIELDS")
        Set OPTIONS = MyFunc.Tables("OPTIONS")
        
    Loop
    
    strCell = "A2"
    wsOutput.Range(strCell).Show
    
    For iField = 1 To FIELDS.ROWCOUNT
        If iField < 27 Then
            strColumn = Chr(64 + iField)
        Else
            strColumn = Chr(64 + Int((iField - 1) / 26)) & Chr(64 + iField - (26 * (Int((iField - 1) / 26))))
        End If
        strCell = strColumn & "1"
        wsOutput.Range(strCell).Value = FIELDS(iField, "FIELDNAME")
        wsOutput.Range(strCell).Font.Bold = True
        wsOutput.Range(strCell).Interior.Color = RGB(222, 222, 222)
        RetVal = DoEvents()
    Next
    
    'rs.Close
    'Close #2
    'Set dbs = Nothing
    'Set rs = Nothing
    'RetVal = SysCmd(acSysCmdRemoveMeter)
    
    '*****************************************
    ' Log off of the SAP system and clean up.
    '*****************************************
    DATA.Rows.RemoveAll
    Set DATA = Nothing
    FIELDS.Rows.RemoveAll
    Set FIELDS = Nothing
    OPTIONS.Rows.RemoveAll
    Set OPTIONS = Nothing
    Set MyFunc = Nothing
    'R3.Connection.logoff
    'Set R3 = Nothing
    SAP_RFC_READ_TABLE = nTotalRecords
End Function

Function NukeTab(strTabName) As Boolean
    Dim objCurrentSheet As Worksheet
    For Each objCurrentSheet In Sheets
        If objCurrentSheet.Name = strTabName Then
            Application.DisplayAlerts = False
            objCurrentSheet.Delete
            Application.DisplayAlerts = True
            NukeTab = True
            Exit Function
        End If
    Next
    NukeTab = False
End Function

Function CreateTab(strTabName) As Worksheet
    Dim objCurrentSheet As Worksheet
    For Each objCurrentSheet In Sheets
        If objCurrentSheet.Name = strTabName Then
            Application.DisplayAlerts = False
            objCurrentSheet.Delete
            Application.DisplayAlerts = True
            Exit For
            'Set CreateTab = objCurrentSheet
            'Exit Function
            'Sheets. (objCurrentSheet)
        End If
    Next
    Set CreateTab = Sheets.Add  
    CreateTab.Name = strTabName
End Function

At the end of the code block above are the NukeTab and the CreateTab function. The NukeTab deletes a Worksheet when it exists. The CreateTabcreates a blank Worksheet in the current spreadsheet (after deleting one of the same name if necessary) and passes a return value that is a Worksheet object.

The OPTIONS parameter that is passed to the RFC is passed in as an internal table. These data act like a WHERE statement without the word "WHERE" and can be used to filter the data like in the examples below.

nRecordCount = SAP_RFC_READ_TABLE(R3, "T134M", "tblT134M", "", "BWKEY like '1%' or BWKEY like '3%'")
nMaterials = SAP_RFC_READ_TABLE(R3, "MARA", "tempMARA", "MATNR,MTART,MATKL,MEINS,NTGEW,BRGEW,GEWEI,PRDHA", "MSTAE EQ '4' AND MTART EQ '" & strMTART & "'")



Handling extracts that exceed Excel's row limit

In some cases, the number of records exceeds 1,048,575; that is the maximum number of data rows in an Excel spreadsheet when using headers. In that case, some simple code can be used to create a new addressing system to poke and peek data into a spreadsheet in a linear fashion.

As an example, these functions below can be used to tease MARC data out of an SAP system when the volume exceeds Excel's row limit. Each one is explained individually.

This first function accepts the R3 connection and a range as parameters. The range includes the Material Masters for which the Plant data will be extracted.

The concatenates a reasonable number of Material Master numbers along with "OR" statements. This allows for more records than are allowed in an IN SQL statement with an array.

This function also teases out the MARD entries and concatenates them as a field on the row in Excel. Finally, the function calls the SetMARC function to poke the record into a larger Worksheet.

Function PopulateMARCbyMATNR(ByRef R3 As Object, objRange As Range) As Long
    Dim nCountMARA As Long, objCell As Object, strMaterial As String, strMaterialFilter As String, nMaterials As Long, nCurrentRow As Long
    Dim nCurSec As Integer, strSkipMaterials As String, strSkipPlants As String, nCurrent As Long
    Const strGetFields As String = "MATNR,WERKS,PSTAT,AUSME,DISMM,DISPO,DISLS,BESKZ,SOBSL,LOSGR,SOBSK,LGPRO,DISGR,LGFSB"
    Dim nLGORTs As Long, nCurrentLGORT As Long, strLGORTs As String, strOptions As String
            
    For Each objCell In objRange.Cells
        If objCell.Value <> "" Then
            strMaterial = objCell.Value
            If InStr(strMaterialFilter, strMaterial) < 1 And InStr(strSkipMaterials, objCell.Value) < 1 Then
                If strMaterialFilter = "" Then
                    strMaterialFilter = "MATNR EQ '" & strMaterial & "'"
                Else
                    strMaterialFilter = strMaterialFilter & " OR MATNR EQ " & "'" & strMaterial & "'"
                End If
                strSkipMaterials = strSkipMaterials & "," & objCell.Value
            End If
            If Len(strMaterialFilter) > 4000 Then
                a = CreateLogEntry("Pulling MARC entries for " & strMaterialFilter)
                nMaterials = SAP_RFC_READ_TABLE(R3, "MARC", "tempMARC", strGetFields, strMaterialFilter)
                If nMaterials > 0 Then
                    nLGORTs = SAP_RFC_READ_TABLE(R3, "MARD", "tempMARD", "MATNR,WERKS,LGORT", strMaterialFilter)
                    a = SortByFirstTwoColumns("tempMARC", nMaterials)
                    a = SortByFirstTwoColumns("tempMARD", nLGORTs)
                    For nCurrentRow = 2 To nMaterials + 1
                        strLGORTs = GetLGORTs(Sheets("tempMARC").Range("A" & nCurrentRow).Value, Sheets("tempMARC").Range("B" & nCurrentRow).Value)
                        Sheets("tempMARC").Range("O" & nCurrentRow).Value = strLGORTs
                        nCountMARC = SetMARC(Sheets("tempMARC").Range("A" & nCurrentRow & ":O" & nCurrentRow))
                        If nCurSec <> Second(Now) Then
                            nCurSec = FlashTab("MARC")
                        End If
                    Next
                End If
                strMaterialFilter = ""
            End If
        End If
        If nCurSec <> Second(Now) Then
            nCurSec = FlashTab("MARC")
        End If
    Next
    If strMaterialFilter <> "" Then
        a = CreateLogEntry("Pulling MARC entries for " & strMaterialFilter)
        nMaterials = SAP_RFC_READ_TABLE(R3, "MARC", "tempMARC", strGetFields, strMaterialFilter)
        If nMaterials > 0 Then
            nLGORTs = SAP_RFC_READ_TABLE(R3, "MARD", "tempMARD", "MATNR,WERKS,LGORT", strMaterialFilter)
            a = SortByFirstTwoColumns("tempMARC", nMaterials)
            a = SortByFirstTwoColumns("tempMARD", nLGORTs)
            For nCurrentRow = 2 To nMaterials + 1
                strLGORTs = GetLGORTs(Sheets("tempMARC").Range("A" & nCurrentRow).Value, Sheets("tempMARC").Range("B" & nCurrentRow).Value)
                Sheets("tempMARC").Range("O" & nCurrentRow).Value = strLGORTs
                nCountMARC = SetMARC(Sheets("tempMARC").Range("A" & nCurrentRow & ":O" & nCurrentRow))
                If nCurSec <> Second(Now) Then
                    nCurSec = FlashTab("MARC")
                End If
            Next
        End If
        strMaterialFilter = ""
    End If
    If nMaterials > 0 Then
        Sheets("MARC").Range("A1:O1").Value = Sheets("tempMARC").Range("A1:O1").Value
        Sheets("MARC").Range("O1").Value = "LGORTS"
        Sheets("MARC").Range("A1:O1").Font.Bold = True
        Sheets("MARC").Range("A1:O1").Interior.Color = RGB(222, 222, 222)
    End If
    nCurrent = NukeTab("tempMARC")
    nCurrent = NukeTab("tempMARD")
    Sheets("MARA").Tab.Color = RGB(222, 222, 22)
    PopulateMARCbyMATNR = nCountMARA
End Function

The GetLGORTs function is simple enough. It combs through the records in the tempMARD tab of the current spreadsheet to concatenate all of the storage locations associated with an Material Master and Plant combination.

It relies on the values in the spreadsheet to be sorted by Material Master number. The code in the SortByFirstTwoColums function (which is documented below this one) sorts these quickly so that this function works.

Function GetLGORTs(strMATNR As String, strWERKS As String) As String
    Dim nCurrent As Long, strLGORTs As String
    Static nCurrentLGORT As Long
    If Sheets("tempMARD").Range("A1").Interior.Color <> RGB(222, 222, 0) Then
        Sheets("tempMARD").Range("A1").Interior.Color = RGB(222, 222, 0)
        nCurrentLGORT = 1
    End If
    If strMATNR = "" Then
        Exit Function
    End If
    Do While Sheets("tempMARD").Range("A" & nCurrentLGORT + 1).Value < strMATNR
        nCurrentLGORT = nCurrentLGORT + 1
        If Sheets("tempMARD").Range("A" & nCurrentLGORT + 1).Value = "" Then
            nCurrentLGORT = 1
            Exit Function
        End If
    Loop
    Do While Sheets("tempMARD").Range("A" & nCurrentLGORT + 1).Value = strMATNR And Sheets("tempMARD").Range("B" & nCurrentLGORT + 1).Value < strWERKS
        nCurrentLGORT = nCurrentLGORT + 1
        If Sheets("tempMARD").Range("A" & nCurrentLGORT + 1).Value = "" Then
            nCurrentLGORT = 1
            Exit Function
        End If
    Loop
    strLGORTs = ""
    Do While Sheets("tempMARD").Range("A" & nCurrentLGORT + 1).Value = strMATNR And Sheets("tempMARD").Range("B" & nCurrentLGORT + 1).Value = strWERKS
        strLGORTs = strLGORTs & Sheets("tempMARD").Range("C" & nCurrentLGORT + 1).Value
        nCurrentLGORT = nCurrentLGORT + 1
    Loop
    GetLGORTs = strLGORTs
End Function

The SortByFirstTwoColumns is an ultra-simple and very fast way to sort rows in an Excel spreadsheet by the first two columns which is usually enough. It accepts as its parameters the name of the Worksheet (strTabName) to be sorted and the number of records to be sorted (nRows); the SAP_RFC_READ_TABLE function returns a long which is the number of entries it retrieved and that value is passed to this function instead of using logic to find the number of records.

Function SortByFirstTwoColumns(strTabName As String, nRows As Long) As Boolean
    ActiveWorkbook.Worksheets(strTabName).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(strTabName).Sort.SortFields.Add Key:=Range("A2:A" & (1 + nRows)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(strTabName).Sort.SortFields.Add Key:=Range("B2:B" & (1 + nRows)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(strTabName).Sort
        .SetRange Range("A2:Z" & (1 + nRows))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Function

The SetMARC function pokes the data in an addressable way into a larger Worksheet in order to exceed Excel's limit on rows. It keeps a static counter and incrments it each time the function is called.

Function SetMARC(objRange As Range) As Long
    Static nCountMARC As Long, wsMARC As Worksheet, nCurrentSet As Long, nCurrent As Long, nCurrentLine As Long
    Dim nRangeLength As Long, nStart As Long
    'Const nSetWidth As Long = 30
    Set wsMARC = Sheets("MARC")
    If wsMARC.Range("A2").Value = "" Then
        nCountMARC = 0 'Refreshed!
    End If
    If nCountMARC = 0 Or objRange.Cells.Count = 1 Then
        For nCurrentSet = 21 To 0 Step -1
            If wsMARC.Range(FindExcelCell(1 + (nCurrentSet * nSetWidth), 2)).Value <> "" Then
                nCountMARC = 1000000 * nCurrentSet
                If nCurrentSet = 0 Then
                    nStart = 2
                Else
                    nStart = 1
                End If
                For nCurrent = nStart To 1048000
                    If wsMARC.Range(FindExcelCell(1 + (nCurrentSet * nSetWidth), nCurrent)).Value <> "" Then
                        nCountMARC = nCountMARC + 1
                    Else
                        Exit For
                    End If
                    If nCurSec <> Second(Now) Then
                        nCurSec = Second(Now)
                        RetVal = DoEvents
                    End If
                Next
                Exit For
            End If
        Next
    End If
    If objRange.Cells.Count > 1 Then
        nCountMARC = nCountMARC + 1
        nCurrentSet = Int(nCountMARC / 1000000)
        nCurrentLine = nCountMARC - Int(nCurrentSet * 1000000)
        'If nCurrentLine > 1000000 Then
        '    nCurrentSet = nCurrentSet + 1
        '    nCurrentLine = nCountMARC - Int(nCurrentSet * 1000000)
        'End If
        nRangeLength = objRange.Cells.Count
        wsMARC.Range(FindExcelCell(1 + (nCurrentSet * nSetWidth), 1 + nCurrentLine) & ":" & FindExcelCell(nRangeLength + (nCurrentSet * nSetWidth), 1 + nCurrentLine)).NumberFormat = "@"
        wsMARC.Range(FindExcelCell(1 + (nCurrentSet * nSetWidth), 1 + nCurrentLine) & ":" & FindExcelCell(nRangeLength + (nCurrentSet * nSetWidth), 1 + nCurrentLine)).Value = objRange.Value
    End If
    SetMARC = nCountMARC
End Function

Finally, the GetMARC function peeks the data out of the Worksheet using an integer representing the record number in a linear fashion. This function and the SetMARC function rely on a global variable called nSetWidth which is delcared as a constant outside of any function or sub.

Const nSetWidth As Long = 30

Function GetMARC(nCurrent As Long, strField As String) As String
    Static nCountMARC As Long, wsMARC As Worksheet, nCurrentSet As Long, nCurrentLine As Long
    'Static nLastCurrent As Long, strLastField As String, strLastValue As String
    Dim nCurrentColumn As Long
    Static strColumns(70) As String
    'Const nSetWidth As Long = 30
    
    'If nCurrent = 0 Then
    '    GetMARC = ""
    '    Exit Function
    'End If
    
    If strColumns(1) = "" Then
        For nCurrentColumn = 1 To 70
            strColumns(nCurrentColumn) = Sheets("MARC").Range(FindExcelCell(nCurrentColumn, 1)).Value
        Next
    End If
    
    nCurrentSet = Int(nCurrent / 1000000)
    nCurrentLine = nCurrent - (1000000 * nCurrentSet)
    
    For nCurrentColumn = 1 To 70
        If strColumns(nCurrentColumn) = strField Then
            Exit For
        End If
    Next
    
    GetMARC = Sheets("MARC").Range(FindExcelCell((nCurrentSet * nSetWidth) + nCurrentColumn, nCurrentLine + 1)).Value
    
End Function



Organize this data so it can be read much faster

Fun with ExcelRather than reading linearly through millions of Plant extension records to find those associated with a particular Material Master, the records can be sorted and then teased out using a for/next loop that starts at the first record and ends at the last record. This shaves hours off of processing and can be done relatively simply.

This sub sorts the MARC records while doing its best to conserve memory. It uses a System.Collections.ArrayList to sneakily sort millions of records in mere seconds instead of using nested loops and spending hours swapping cells in the spreadsheet.

Sub SortMARC()
    Dim nCurrentColumn As Long, nCurrent As Long, nCurrent2 As Long, nCurSec As Long
    Dim nCountMARC As Long, strTemp As Variant
    Dim nCurrentSet As Long, nCurrentLine As Long
    Dim nCurrentSet2 As Long, nCurrentLine2 As Long
    
    Static strColumns(70) As String
    'Const nSetWidth As Long = 30
        
    'Get the number of Plant extensions in the MARC tab...
    nCountMARC = SetMARC(Range("ZZ9"))
    
    'Set these to be stored as text.
    'Sheets("MARC").Range(FindExcelCell(1, 1048570) & ":" & FindExcelCell(70, 1048570)).NumberFormat = "@"
    Sheets("MARC").Range("A1048570").Value = "Sorted"
        
    Dim arr As Object
    Dim cell As Range
    
    Set arr = CreateObject("System.Collections.ArrayList")
    For nCurrent = 1 To nCountMARC
        nCurrentSet = Int(nCurrent / 1000000)
        nCurrentLine = nCurrent - (1000000 * nCurrentSet)
        strTemp = Sheets("MARC").Range(FindExcelCell((nCurrentSet * nSetWidth) + 1, nCurrentLine + 1)).Value & Right("000000000" & nCurrent, 9)
        arr.Add strTemp
        If nCurSec <> Second(Now) Then
            nCurSec = Second(Now)
            If nCurSec / 2 = Int(nCurSec / 2) Then
                Sheets("MARC").Tab.Color = RGB(222, 22, 222)
            Else
                Sheets("MARC").Tab.Color = RGB(111, 11, 111)
            End If
            RetVal = DoEvents
        End If
    Next
    arr.Sort
    
    Dim wsTemp As Worksheet
    Set wsTemp = CreateTab("tempMARC")
    
    nCurrent = 0
    For Each strTemp In arr
        nCurrent = nCurrent + 1
        nCurrent2 = Val(Mid(strTemp, 19, 9))
        If nCurrent <> nCurrent2 Then
            nCurrentSet = Int(nCurrent / 1000000)
            nCurrentLine = nCurrent - (1000000 * nCurrentSet)
            nCurrentSet2 = Int(nCurrent2 / 1000000)
            nCurrentLine2 = nCurrent2 - (1000000 * nCurrentSet2)

            Sheets("tempMARC").Range(FindExcelCell((nCurrentSet * nSetWidth) + 1, nCurrentLine + 1) & ":" & FindExcelCell((nCurrentSet * nSetWidth) + nSetWidth, nCurrentLine + 1)).NumberFormat = "@"
            Sheets("tempMARC").Range(FindExcelCell((nCurrentSet * nSetWidth) + 1, nCurrentLine + 1) & ":" & FindExcelCell((nCurrentSet * nSetWidth) + nSetWidth, nCurrentLine + 1)).Value = Sheets("MARC").Range(FindExcelCell((nCurrentSet * nSetWidth) + 1, nCurrentLine + 1) & ":" & FindExcelCell((nCurrentSet * nSetWidth) + nSetWidth, nCurrentLine + 1)).Value
            If nCurrent2 < nCurrent Then
                Sheets("MARC").Range(FindExcelCell((nCurrentSet * nSetWidth) + 1, nCurrentLine + 1) & ":" & FindExcelCell((nCurrentSet * nSetWidth) + nSetWidth, nCurrentLine + 1)).Value = Sheets("tempMARC").Range(FindExcelCell((nCurrentSet2 * nSetWidth) + 1, nCurrentLine2 + 1) & ":" & FindExcelCell((nCurrentSet2 * nSetWidth) + nSetWidth, nCurrentLine2 + 1)).Value
                Sheets("tempMARC").Range(FindExcelCell((nCurrentSet2 * nSetWidth) + 1, nCurrentLine2 + 1) & ":" & FindExcelCell((nCurrentSet2 * nSetWidth) + nSetWidth, nCurrentLine2 + 1)).Clear
            Else
                Sheets("MARC").Range(FindExcelCell((nCurrentSet * nSetWidth) + 1, nCurrentLine + 1) & ":" & FindExcelCell((nCurrentSet * nSetWidth) + nSetWidth, nCurrentLine + 1)).Value = Sheets("MARC").Range(FindExcelCell((nCurrentSet2 * nSetWidth) + 1, nCurrentLine2 + 1) & ":" & FindExcelCell((nCurrentSet2 * nSetWidth) + nSetWidth, nCurrentLine2 + 1)).Value
            End If
            'Sheets("MARC").Range(FindExcelCell((nCurrentSet2 * nSetWidth) + 1, nCurrentLine2 + 1) & ":" & FindExcelCell((nCurrentSet2 * nSetWidth) + nSetWidth, nCurrentLine2 + 1)).Value = Sheets("MARC").Range(FindExcelCell(1, 1048570) & ":" & FindExcelCell(70, 1048570)).Value
        End If
        If nCurSec <> Second(Now) Then
            nCurSec = Second(Now)
            If nCurSec / 2 = Int(nCurSec / 2) Then
                Sheets("MARC").Tab.Color = RGB(222, 22, 222)
            Else
                Sheets("MARC").Tab.Color = RGB(111, 11, 111)
            End If
            Sheets("tempMARC").Range("A1").Value = "Sorting...  " & Int(100 * (nCurrent / nCountMARC)) & "% completed."
            RetVal = DoEvents
        End If
    Next
    
    Set arr = Nothing
    a = NukeTab("tempMARC")
    
End Sub

When the GetMARCRange function is called, it combs through the data to find the first instance of the Material Master and then the last and then returns the two values as an 18-digit string value. The first nine digits are the first instance of the Material Master and the last nine digits are the last and can be called as in the sample code below.

Function CountMARCEntries(strMATNR as string) as long
    Dim strRange as string, nCurrent as long, nCount as long
    nCount = 0
    strRange = GetMARCRange(strMATNR)
    For nCurrent = Val(Left(strRange, 9)) To Val(Right(strRange, 9))
        nCount = nCount + 1
    Next
    CountMARCEntries = nCount
End Function


Function GetMARCRange(strMATNR As String) As String
    Static nCount As Long, strRanges(999999, 1) As String, nCountMARC As Long
    Static strLastMATNR As String, nLastLast As Long, nStart As Long
    Dim nCurrent As Long, nFirst As Long, nLast As Long, nCurrentMATNR As String
    
    nStart = 1
    
    If Sheets("MARC").Range("A1048570").Value <> "" Then
        'This was just sorted.  Start from scratch...
        Sheets("MARC").Range("A1048570").Value = ""
        nCount = 0
        nCountMARC = 0
        nLastLast = 1
    End If
    
    
    For nCurrent = 1 To nCount
        If strRanges(nCurrent, 1) = strMATNR Then
            GetMARCRange = strRanges(nCurrent, 0)
            Exit Function
        End If
    Next
    
    If nCountMARC = 0 Then
        nCountMARC = SetMARC(Range("ZZ9"))
    End If
    
    'Seriously speed this process up . . .
    If strLastMATNR < strMATNR And nLastLast <> 0 Then
        nStart = nLastLast
    Else
        For nCurrent = 1000 To nCountMARC - 2000 Step 1000
            If GetMARC(nCurrent, "MATNR") < strMATNR Then
                nStart = nCurrent
            Else
                Exit For
            End If
        Next
    End If
    
    nFirst = 0
    nLast = 0
    For nCurrent = nStart To nCountMARC
        If GetMARC(nCurrent, "MATNR") = strMATNR Then
            If nFirst = 0 Then
                nFirst = nCurrent
            End If
            nLast = nCurrent
        Else
            If nLast > 0 Then
                Exit For
            End If
            If GetMARC(nCurrent, "MATNR") > strMATNR Then
                'The Material Master isn't in this list.
                Exit For
            End If
        End If
    Next
    nCount = nCount + 1
    strRanges(nCount, 1) = strMATNR
    strRanges(nCount, 0) = Right("000000000" & nFirst, 9) & Right("000000000" & nLast, 9)
    GetMARCRange = strRanges(nCount, 0)
    strLastMATNR = strMATNR
    nLastLast = nLast
End Function



Fun with Excel


Fun with Excel

excel1
Programming Language: 
ABAP