0
\$\begingroup\$

Wondering about efficiency here - I have a bit of code that does what I want; but it is terribly slow. I structured the code in a way that made sense to me logically, but I'm wondering if someone else could take a look at the code and find a shortcut or two that might make it faster. I'm guessing that I am referencing the Worksheet too often in one of the loops, but haven't been able to find a good way to restructure to improve performance.

What is it doing: Each row contains a record with a single ID, Name, etc. on the row. There are also multiple response items that work together and those are basically a table or array that is 9 columns wide and however many rows tall based on the current Alternate Logic in the table. So if a single record has 2 types of alternate logic at the beginning, the array would be (1 to 9, 1 to 2) or I guess (0 to 8, 0 to 1). I'm basically looking for a specific row in the existing table and then adding new lines. So when I'm done, I expect the array to be taller by at least one more row.

Why are we doing it? Each record is a charge code for a hospital, and the charge codes have a default Revenue Code, but depending on the cost center or payer - an alternate Revenue Code may be needed. I need to copy all lines where a specific cost center is used to identify alternate Revenue Codes and then copy that existing data and add my new line(s) where the only change on the new lines from the source line is the cost center ID itself.

Option Explicit

Sub addAlternateRevCodeLogic()
Dim WS As Worksheet
Dim rng As Range
Dim lastColumn As Long
Dim row As Long
Dim i As Long

Dim ReferenceStyle As XlReferenceStyle

'Arrays of the different Alt Rev Code fields on an EAP
Dim AltID() As String
Dim EffFrom() As String
Dim EffTo() As String
Dim ProvType() As String
Dim BCC() As String
Dim DEP() As String
Dim EAF() As String
Dim Class() As String
Dim RevCode() As String

'Alt Rev Code data from the matching rows
Dim rowAltID As String
Dim rowEffFrom As String
Dim rowEffTo As String
Dim rowProvType As String
Dim rowBCC As String
Dim rowDEP As String
Dim rowEAF As String
Dim rowClass As String
Dim rowRevCode As String

'New and old cost centers
Dim newBCC() As String
Dim oldBCC As String
Dim CostCenter As Variant
Dim userInput As String

'Columns for Rev Code Ranges
Dim AltIDcol As Long 'I EAP 2431
Dim EffFromcol As Long 'I EAP 2434
Dim EffTocol As Long 'I EAP 2435
Dim ProvTypecol As Long 'I EAP 2439
Dim BCCcol As Long 'I EAP 2438
Dim DEPcol As Long 'I EAP 2437
Dim EAFcol As Long 'I EAP 2436
Dim Classcol As Long 'I EAP 2432
Dim RevCodecol As Long 'I EAP 2433

Application.ScreenUpdating = False
ReferenceStyle = Application.ReferenceStyle
If ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlA1 'There are certain assumptions in the ranges that don't play nicely with R1C1

'Data is Chr(10) delimited
'Define the range of the EAP Export
Set WS = Worksheets("export")
lastColumn = eap.Cells.Find("*", After:=eap.Cells(1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
Set rng = WS.Range("A1", WS.Columns(1).Find(what:="#LAST_ROW", LookIn:=xlComments, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Offset(0, lastColumn))

'Define all of the column IDs
AltIDcol = FindCol(2431, eap, True, 1, 1, 1, lastColumn)
EffFromcol = FindCol(2434, eap, True, 1, 1, 1, lastColumn)
EffTocol = FindCol(2435, eap, True, 1, 1, 1, lastColumn)
ProvTypecol = FindCol(2439, eap, True, 1, 1, 1, lastColumn)
BCCcol = FindCol(2438, eap, True, 1, 1, 1, lastColumn)
DEPcol = FindCol(2437, eap, True, 1, 1, 1, lastColumn)
EAFcol = FindCol(2436, eap, True, 1, 1, 1, lastColumn)
Classcol = FindCol(2432, eap, True, 1, 1, 1, lastColumn)
RevCodecol = FindCol(2433, eap, True, 1, 1, 1, lastColumn)

oldBCC = InputBox("What cost center do you want to copy?" & vbNewLine & "Select only one, and don't make typos")
If oldBCC = "" Then MsgBox "Must choose a cost center!", vbOKOnly + vbCritical: Exit Sub

Do
    userInput = InputBox("What are the new cost centers that need added?" & vbNewLine & "You can enter multiple, just keep adding them and then leave the box blank after the last one" & vbNewLine & "Don't make typos", "New Cost Centers")
    Select Case True
        Case CostCenter = "" And userInput <> "" 'Handle the 1st cost center
            CostCenter = userInput
        Case CostCenter <> "" And userInput <> "" 'Handle each new input
            CostCenter = CostCenter & "," & userInput
        Case CostCenter = "" And userInput = "" 'Handle no input
            MsgBox "Must choose at least one new cost center!", vbOKOnly + vbCritical: Exit Sub
    End Select
Loop While userInput <> ""

'oldBCC = "10005320" 'Test Emergency Cost Center
'oldBCC = "10004320" 'Test Pediatrics Cost Center
'CostCenter = "70005320" 'Test New Emergency Cost Center
'CostCenter = "70004110,70004130,70004140,70004200,70004420,70004510,70004400,70004430,70004500" 'Test New Pediatrics Cost Centers
newBCC() = Split(CostCenter, ",")

With rng
    For row = LBound(.Value2) To UBound(.Value2) 'Loop through each row from the export
    If Not IsEmpty(.Value2(row, RevCodecol)) Then 'Find any row that contains an alternate revenue code
        If InStr(1, .Value2(row, BCCcol), oldBCC) Then 'Check if the TRH Emergency Cost Center is using one of the alternate revenue codes
            'Build an array for each Alt Rev Code data item
            RevCode() = Split(.Value2(row, RevCodecol), Chr(10))
            AltID() = Split(.Value2(row, AltIDcol), Chr(10))
            EffFrom() = Split(.Value2(row, EffFromcol), Chr(10))
            EffTo() = Split(.Value2(row, EffTocol), Chr(10))
            ProvType() = Split(.Value2(row, ProvTypecol), Chr(10))
            BCC() = Split(.Value2(row, BCCcol), Chr(10))
            DEP() = Split(.Value2(row, DEPcol), Chr(10))
            EAF() = Split(.Value2(row, EAFcol), Chr(10))
            Class() = Split(.Value2(row, Classcol), Chr(10))
            For i = LBound(RevCode()) To UBound(RevCode())
                If InStr(1, BCC(i), oldBCC) Then 'Set row data for a line with the cost center to copy
                    rowAltID = AltID(i)
                    rowEffFrom = EffFrom(i)
                    rowEffTo = EffTo(i)
                    rowProvType = ProvType(i)
                    rowBCC = BCC(i)
                    rowDEP = DEP(i)
                    rowEAF = EAF(i)
                    rowClass = Class(i)
                    rowRevCode = RevCode(i)
                    'Copy the existing value and add the new line(s)
                    For Each CostCenter In newBCC 'Copy existing lines and add a new entry for each new cost center
                        .Cells(row, AltIDcol).Value = .Value2(row, AltIDcol) & Chr(10) & rowAltID ' & Chr(10)
                        .Cells(row, EffFromcol).Value = .Value2(row, EffFromcol) & Chr(10) & rowEffFrom ' & Chr(10)
                        .Cells(row, EffTocol).Value = .Value2(row, EffTocol) & Chr(10) & rowEffTo ' & Chr(10)
                        .Cells(row, ProvTypecol).Value = .Value2(row, ProvTypecol) & Chr(10) & rowProvType ' & Chr(10)
                        .Cells(row, BCCcol).Value = .Value2(row, BCCcol) & Chr(10) & CostCenter ' & Chr(10)
                        .Cells(row, DEPcol).Value = .Value2(row, DEPcol) & Chr(10) & rowDEP ' & Chr(10)
                        .Cells(row, EAFcol).Value = .Value2(row, EAFcol) & Chr(10) & rowEAF ' & Chr(10)
                        .Cells(row, Classcol).Value = .Value2(row, Classcol) & Chr(10) & rowClass ' & Chr(10)
                        .Cells(row, RevCodecol).Value = .Value2(row, RevCodecol) & Chr(10) & rowRevCode ' & Chr(10)
                    Next CostCenter
                End If
            Next i
        End If
    End If
    Next row
End With
If ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlR1C1
Application.ScreenUpdating = True
MsgBox "Rev Codes updated. Test the import.", vbInformation + vbOKOnly
End Sub
```
\$\endgroup\$
6
  • 1
    \$\begingroup\$ Welcome to the Code Review Community. We need some background details. How much data is being processed? Please quantify terribly slow. \$\endgroup\$
    – pacmaninbw
    Commented Mar 1, 2021 at 14:56
  • \$\begingroup\$ You need to explain better what your code is trying to do in a fair bit of detail rather than just dumping code here and expecting us to fathom its working. You should also take the time to update your code with more meaningful and user friendly variable names. At present, your code is fairly impenetrable. \$\endgroup\$
    – Freeflow
    Commented Mar 1, 2021 at 16:00
  • \$\begingroup\$ 1. Terribly slow is several minutes for about 900 rows in a spreadsheet. 2. Wasn't a fan of pasting the code in initially, but let's say I get rid of most of the code block and just provide an example - would that suffice? I found that saying in words what I was trying to do was difficult and there was a not that "The more code you share, the better" so I went big \$\endgroup\$
    – immobile2
    Commented Mar 1, 2021 at 16:27
  • 1
    \$\begingroup\$ If you can't explain what you want to do simply and succinctly there's little chance of being able to write decent code as typically the inability to explain is linked to a lack of understanding about what is required and how to translate the requirement into code. So please, for now, just focus on clearly and succinctly explaining what it is you are trying to achieve. \$\endgroup\$
    – Freeflow
    Commented Mar 1, 2021 at 16:36
  • 1
    \$\begingroup\$ Hi, don't worry lots of code is good, we need all the info we can get! Indeed you haven't included the FindCol function and I'm guessing eap is your worksheet's code name because I can't see it defined anywhere, but do confirm? In terms of extra context, it would be useful to include a sample of the data to see if its structure yields some insight. As it stands this is doing much more than just copying data from one place to another adding newlines so if you could explain that in more detail, the why of your code, it would help people understand it to give useful feedback. \$\endgroup\$
    – Greedo
    Commented Mar 3, 2021 at 9:49

2 Answers 2

1
\$\begingroup\$

You are right in what you are thinking: reading from and writing to the worksheet is notoriously slow.

Without doing anything else, you will probably get a significant performance boost just from turning Calculation off at the same place in your code where you are turning ScreenUpdating on and off:

    'Variable Declarations

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

    'The rest of your code here

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True

It would be so much easier if each existing cost center was on its own row instead of having many in each! We'll just assume that you don't have any control over this and commiserate with you :)

Each time your code finds the user-input old cost code in the BCCcol column, it copies the old cost code details in that row. Then it appends the cells in that row with the new cost code(s) and those copied details.

If you were to use one of your commented test examples:

'oldBCC = "10004320" 'Test Pediatrics Cost Center
'CostCenter = "70004110,70004130,70004140,70004200,70004420,70004510,70004400,70004430,70004500" 'Test New Pediatrics Cost Centers

There are nine new cost centers in CostCenter, so each time your code finds oldBCC in a row, it appends the cells in that row nine times. There are nine cells to append each time, so that's 81 separate writes to the worksheet for each row where there is a match. This will be slow.

There must be a better way to go than splitting each relevant cell into its own little array, but I'm going to leave that for someone more experienced that me.

I'm not sure your row string variables are adding much benefit either (e.g. rowAltID). I think the code for appending the new cost centers would be just as easy to read without them (but I also don't think they're slowing your code down much).

If you were to write each cell's new value to a string variable and then only update the cells in the row with the new string variables once at the end you should see another large improvement. I'll use the AltID column as an example:

Dim newAltID As String

    '...string declarations for the other cells go here...

    '...then other initial code as before...

For i = LBound(RevCode()) To UBound(RevCode())

    If InStr(1, BCC(i), oldBCC) Then 'Set row data for a line with the cost center to copy
    
        'Put the existing cell values into their string variables
        newAltID = .Cells(row, AltIDcol).Value

            '...continue for the other cell's strings

    
        For Each CostCenter In newBCC 'Add a new entry for each new cost center

            newAltID = newAltID  & Chr(10) & AltID(i)
            'or newAltID = newAltID  & Chr(10) & rowAltID 

                '...continue for the other cell's strings

        Next CostCenter

        'Then write the appended strings back to the worksheet once at the end
        .Cells(row, AltIDcol).Value = newAltID

            '...continue for the other cell's strings

    End If

Next i

Edit: removed personal opinion where it was unnecessary.

\$\endgroup\$
1
  • \$\begingroup\$ Thanks for the insight, I don't have a spreadsheet handy at the moment, but I'll update my question with an example to help visualize. I do technically have the option to split the data to different rows rather than Chr(10) delimited, but it adds a bit of extra complexity I wanted to avoid, especially the fact that insert row is going to be slow. This is really helpful though and I realize now that the main drag is the writing part, so I'm thinking about saving the source data into a variant array variable, making all updates in a new array, and then writing the entire array at once-Copy/paste \$\endgroup\$
    – immobile2
    Commented Mar 13, 2021 at 15:25
0
\$\begingroup\$

Ok i'll try have a crack it with the info you've given... the code isnt going to be elegant but i've tried my best. I cant check if the code works since i dont have the full code / sheet you've provided.

If you are not interested in how it all works go to the bottom of the post and you'll see the full code combined together. just copy and paste and see if it works!

As a few of the answers mentioned commincating with a sheet can be extremely slow (especially if you've got calculations on at the same time).

At the start of your code i would recommond:

Application.ScreenUpdating = True '**** see below
Application.Calculation = xlCalculationManual

' if your code errors and produces a pop up this can cause your excel to crash i prefer to keep this until you are well versed with how VBA works
' if your code is fully using arrays then screen updating usually provides a negligible benefit
' if you are unfamiliar with using arrays i suggest finalising your code and then turning it off

At the end of your code i would recommond:

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic

Method:

  1. Loop through the data (as an array this time and not a range)
  2. Find out the size of the new insert
  3. Loop through the data again this time into the array
  4. paste the data at the bottom of the sheet

Looping through an array twice should still be 100x (dont quote me) faster.

I've made two assumptions:

  1. The section of code below gets the data from the sheet called "export" with column one being the master column (the one if you go to the end it shows the last row)
  2. You paste the data back into the 'Export' sheet at the bottom of the page to the next line.

for point 1 - i've replaced the following code:

set WS = Worksheets("export")
lastColumn = eap.Cells.Find("*", After:=eap.Cells(1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
Set rng = WS.Range("A1", WS.Columns(1).Find(what:="#LAST_ROW", LookIn:=xlComments, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext,    MatchCase:=False).Offset(0, lastColumn))

with:

Dim arr() As Variant
arr() = GetArr("export")

for point 2 - i've added the following code at the end:

PasteArr "export", arrNew, 1, False, True

I've added two functions: one to get the array from the sheet, one to paste the array to the sheet


'------- ---------------------- ---------
'------- Get Data into an Array ---------
'------- ---------------------- ---------

Function GetArr(SheetName As String, Optional ColumnForSize As Long = 1, Optional Rowstart As Long = 1)

Dim ws As Worksheet
Dim vArray() As Variant

On Error GoTo ErrH
    Set ws = ThisWorkbook.Sheets(SheetName):    On Error GoTo 0
    
With ws
    If .FilterMode = True Then .ShowAllData
    lRow = .Cells(.Rows.Count, ColumnForSize).End(xlUp).row
    lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    If lRow > 1 Or lCol > 1 Then
        vArray() = .Cells(Rowstart, 1).Resize(lRow - Rowstart + 1, lCol).Value2
        GetArr = vArray()
    End If
End With

EndFunction:
Exit Function

ErrH:
Debug.Print "Worksheet name '" & SheetName & "' not found."
Resume EndFunction

End Function



'------- -------------------- ---------
'------- Paste Array to Sheet ---------
'------- -------------------- ---------

Function PasteArr(SheetName As String, vArray() As Variant, Optional ColumnForSize As Long = 1, Optional bClearContents As Boolean = True, Optional bLastRow As Boolean, Optional bOmitFirstRow As Boolean)

Dim ws As Worksheet

On Error GoTo ErrH
    Set ws = ThisWorkbook.Sheets(SheetName): On Error GoTo 0

x = 0

With ws
    If .FilterMode = True Then .ShowAllData
    If bClearContents Then
        lRow = .Cells(.Rows.Count, ColumnForSize).End(xlUp).row
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        If lRow > 1 Then .Cells(1, 1).Resize(lRow, lCol).ClearContents
    End If
    If bOmitFirstRow Then
        For i = LBound(vArray, 2) To UBound(vArray, 2)
            vArray(LBound(vArray), i) = vArray(UBound(vArray), i)
            vArray(UBound(vArray), i) = ""
        Next
        x = 1
    End If
    If Not (Not vArray()) Then
        If bLastRow Then
            lRow = .Cells(.Rows.Count, ColumnForSize).End(xlUp).row + 1
            .Cells(lRow, 1).Resize(UBound(vArray) - x, UBound(vArray, 2)) = vArray()
        Else
            .Cells(1, 1).Resize(UBound(vArray) - x, UBound(vArray, 2)) = vArray()
        End If
    End If
End With


EndFunction:
Exit Function

ErrH:
Debug.Print "Worksheet name '" & SheetName & "' not found."
Resume EndFunction

End Function

Packaging all the above comments together this is what it looks like:


Option Base 1

Sub addAlternateRevCodeLogic()

Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual

Dim ws As Worksheet
Dim rng As Range
Dim lastColumn As Long
Dim row As Long
Dim i As Long

Dim ReferenceStyle As XlReferenceStyle

'Arrays of the different Alt Rev Code fields on an EAP
Dim AltID() As String
Dim EffFrom() As String
Dim EffTo() As String
Dim ProvType() As String
Dim BCC() As String
Dim DEP() As String
Dim EAF() As String
Dim Class() As String
Dim RevCode() As String


'Alt Rev Code data from the matching rows
Dim rowAltID As String
Dim rowEffFrom As String
Dim rowEffTo As String
Dim rowProvType As String
Dim rowBCC As String
Dim rowDEP As String
Dim rowEAF As String
Dim rowClass As String
Dim rowRevCode As String

'New and old cost centers
Dim newBCC() As String
Dim oldBCC As String
Dim CostCenter As Variant
Dim userInput As String

'Columns for Rev Code Ranges
Dim AltIDcol As Long 'I EAP 2431
Dim EffFromcol As Long 'I EAP 2434
Dim EffTocol As Long 'I EAP 2435
Dim ProvTypecol As Long 'I EAP 2439
Dim BCCcol As Long 'I EAP 2438
Dim DEPcol As Long 'I EAP 2437
Dim EAFcol As Long 'I EAP 2436
Dim Classcol As Long 'I EAP 2432
Dim RevCodecol As Long 'I EAP 2433

'Application.ScreenUpdating = False
ReferenceStyle = Application.ReferenceStyle
If ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlA1 'There are certain assumptions in the ranges that don't play nicely with R1C1

'Data is Chr(10) delimited
'Define the range of the EAP Export
Dim arr() As Variant
Dim arrNew() As Variant
arr() = GetArr("export")


'Define all of the column IDs
AltIDcol = FindCol(2431, eap, True, 1, 1, 1, lastColumn)
EffFromcol = FindCol(2434, eap, True, 1, 1, 1, lastColumn)
EffTocol = FindCol(2435, eap, True, 1, 1, 1, lastColumn)
ProvTypecol = FindCol(2439, eap, True, 1, 1, 1, lastColumn)
BCCcol = FindCol(2438, eap, True, 1, 1, 1, lastColumn)
DEPcol = FindCol(2437, eap, True, 1, 1, 1, lastColumn)
EAFcol = FindCol(2436, eap, True, 1, 1, 1, lastColumn)
Classcol = FindCol(2432, eap, True, 1, 1, 1, lastColumn)
RevCodecol = FindCol(2433, eap, True, 1, 1, 1, lastColumn)

oldBCC = InputBox("What cost center do you want to copy?" & vbNewLine & "Select only one, and don't make typos")
If oldBCC = "" Then MsgBox "Must choose a cost center!", vbOKOnly + vbCritical: Exit Sub

Do
    userInput = InputBox("What are the new cost centers that need added?" & vbNewLine & "You can enter multiple, just keep adding them and then leave the box blank after the last one" & vbNewLine & "Don't make typos", "New Cost Centers")
    Select Case True
        Case CostCenter = "" And userInput <> "" 'Handle the 1st cost center
            CostCenter = userInput
        Case CostCenter <> "" And userInput <> "" 'Handle each new input
            CostCenter = CostCenter & "," & userInput
        Case CostCenter = "" And userInput = "" 'Handle no input
            MsgBox "Must choose at least one new cost center!", vbOKOnly + vbCritical: Exit Sub
    End Select
Loop While userInput <> ""

'oldBCC = "10005320" 'Test Emergency Cost Center
'oldBCC = "10004320" 'Test Pediatrics Cost Center
'CostCenter = "70005320" 'Test New Emergency Cost Center
'CostCenter = "70004110,70004130,70004140,70004200,70004420,70004510,70004400,70004430,70004500" 'Test New Pediatrics Cost Centers
newBCC() = Split(CostCenter, ",")

xCounter = 0
For row = LBound(arr) To UBound(arr) 'Loop through each row from the export
    If Not IsEmpty(arr(row, RevCodecol)) Then 'Find any row that contains an alternate revenue code
        If InStr(1, arr(row, BCCcol), oldBCC) Then 'Check if the TRH Emergency Cost Center is using one of the alternate revenue codes
            'Build an array for each Alt Rev Code data item
            RevCode() = Split(arr(row, RevCodecol), Chr(10))
            AltID() = Split(arr(row, AltIDcol), Chr(10))
            EffFrom() = Split(arr(row, EffFromcol), Chr(10))
            EffTo() = Split(arr(row, EffTocol), Chr(10))
            ProvType() = Split(arr(row, ProvTypecol), Chr(10))
            BCC() = Split(arr(row, BCCcol), Chr(10))
            DEP() = Split(arr(row, DEPcol), Chr(10))
            EAF() = Split(arr(row, EAFcol), Chr(10))
            Class() = Split(arr(row, Classcol), Chr(10))
            For i = LBound(RevCode()) To UBound(RevCode())
                If InStr(1, BCC(i), oldBCC) Then 'Set row data for a line with the cost center to copy
                    rowAltID = AltID(i)
                    rowEffFrom = EffFrom(i)
                    rowEffTo = EffTo(i)
                    rowProvType = ProvType(i)
                    rowBCC = BCC(i)
                    rowDEP = DEP(i)
                    rowEAF = EAF(i)
                    rowClass = Class(i)
                    rowRevCode = RevCode(i)
                    'Copy the existing value and add the new line(s)
                    For Each CostCenter In newBCC 'Copy existing lines and add a new entry for each new cost center
                        xCounter = xCounter = 1
                    Next CostCenter
                End If
            Next i
        End If
    End If
Next

If xCounter > 0 Then
    ReDim arrNew(xCounter, UBound(arr, 2))
    xCounter = 0
    For row = LBound(arr) To UBound(arr) 'Loop through each row from the export
        If Not IsEmpty(arr(row, RevCodecol)) Then 'Find any row that contains an alternate revenue code
            If InStr(1, arr(row, BCCcol), oldBCC) Then 'Check if the TRH Emergency Cost Center is using one of the alternate revenue codes
                'Build an array for each Alt Rev Code data item
                RevCode() = Split(arr(row, RevCodecol), Chr(10))
                AltID() = Split(arr(row, AltIDcol), Chr(10))
                EffFrom() = Split(arr(row, EffFromcol), Chr(10))
                EffTo() = Split(arr(row, EffTocol), Chr(10))
                ProvType() = Split(arr(row, ProvTypecol), Chr(10))
                BCC() = Split(arr(row, BCCcol), Chr(10))
                DEP() = Split(arr(row, DEPcol), Chr(10))
                EAF() = Split(arr(row, EAFcol), Chr(10))
                Class() = Split(arr(row, Classcol), Chr(10))
                For i = LBound(RevCode()) To UBound(RevCode())
                    If InStr(1, BCC(i), oldBCC) Then 'Set row data for a line with the cost center to copy
                        rowAltID = AltID(i)
                        rowEffFrom = EffFrom(i)
                        rowEffTo = EffTo(i)
                        rowProvType = ProvType(i)
                        rowBCC = BCC(i)
                        rowDEP = DEP(i)
                        rowEAF = EAF(i)
                        rowClass = Class(i)
                        rowRevCode = RevCode(i)
                        'Copy the existing value and add the new line(s)
                        For Each CostCenter In newBCC 'Copy existing lines and add a new entry for each new cost center
                            xCounter = xCounter = 1
                            arrNew(xCounter, AltIDcol).Value = arr(row, AltIDcol) & Chr(10) & rowAltID ' & Chr(10)
                            arrNew(xCounter, EffFromcol).Value = arr(row, EffFromcol) & Chr(10) & rowEffFrom ' & Chr(10)
                            arrNew(xCounter, EffTocol).Value = arr(row, EffTocol) & Chr(10) & rowEffTo ' & Chr(10)
                            arrNew(xCounter, ProvTypecol).Value = arr(row, ProvTypecol) & Chr(10) & rowProvType ' & Chr(10)
                            arrNew(xCounter, BCCcol).Value = arr(row, BCCcol) & Chr(10) & CostCenter ' & Chr(10)
                            arrNew(xCounter, DEPcol).Value = arr(row, DEPcol) & Chr(10) & rowDEP ' & Chr(10)
                            arrNew(xCounter, EAFcol).Value = arr(row, EAFcol) & Chr(10) & rowEAF ' & Chr(10)
                            arrNew(xCounter, Classcol).Value = arr(row, Classcol) & Chr(10) & rowClass ' & Chr(10)
                            arrNew(xCounter, RevCodecol).Value = arr(row, RevCodecol) & Chr(10) & rowRevCode ' & Chr(10)
                        Next CostCenter
                    End If
                Next i
            End If
        End If
    Next
End If


PasteArr "export", arrNew, 1, False, True

Application.Calculation = xlCalculationAutomatic

If ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlR1C1
Application.ScreenUpdating = True
MsgBox "Rev Codes updated. Test the import.", vbInformation + vbOKOnly

End Sub


'------- ---------------------- ---------
'------- Get Data into an Array ---------
'------- ---------------------- ---------

Function GetArr(SheetName As String, Optional ColumnForSize As Long = 1, Optional Rowstart As Long = 1)

Dim ws As Worksheet
Dim vArray() As Variant

On Error GoTo ErrH
    Set ws = ThisWorkbook.Sheets(SheetName):    On Error GoTo 0
    
With ws
    If .FilterMode = True Then .ShowAllData
    lRow = .Cells(.Rows.Count, ColumnForSize).End(xlUp).row
    lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    If lRow > 1 Or lCol > 1 Then
        vArray() = .Cells(Rowstart, 1).Resize(lRow - Rowstart + 1, lCol).Value2
        GetArr = vArray()
    End If
End With

EndFunction:
Exit Function

ErrH:
Debug.Print "Worksheet name '" & SheetName & "' not found."
Resume EndFunction

End Function



'------- -------------------- ---------
'------- Paste Array to Sheet ---------
'------- -------------------- ---------

Function PasteArr(SheetName As String, vArray() As Variant, Optional ColumnForSize As Long = 1, Optional bClearContents As Boolean = True, Optional bLastRow As Boolean, Optional bOmitFirstRow As Boolean)

Dim ws As Worksheet

On Error GoTo ErrH
    Set ws = ThisWorkbook.Sheets(SheetName): On Error GoTo 0

x = 0

With ws
    If .FilterMode = True Then .ShowAllData
    If bClearContents Then
        lRow = .Cells(.Rows.Count, ColumnForSize).End(xlUp).row
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        If lRow > 1 Then .Cells(1, 1).Resize(lRow, lCol).ClearContents
    End If
    If bOmitFirstRow Then
        For i = LBound(vArray, 2) To UBound(vArray, 2)
            vArray(LBound(vArray), i) = vArray(UBound(vArray), i)
            vArray(UBound(vArray), i) = ""
        Next
        x = 1
    End If
    If Not (Not vArray()) Then
        If bLastRow Then
            lRow = .Cells(.Rows.Count, ColumnForSize).End(xlUp).row + 1
            .Cells(lRow, 1).Resize(UBound(vArray) - x, UBound(vArray, 2)) = vArray()
        Else
            .Cells(1, 1).Resize(UBound(vArray) - x, UBound(vArray, 2)) = vArray()
        End If
    End If
End With


EndFunction:
Exit Function

ErrH:
Debug.Print "Worksheet name '" & SheetName & "' not found."
Resume EndFunction

End Function
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.