Скопируйте блок данных в существующие ячейки, добавив новую строку

Интересно, здесь ли эффективность – у меня есть небольшой код, который делает то, что я хочу; но это ужасно медленно. Я структурировал код таким образом, чтобы это имело для меня логический смысл, но мне интересно, может ли кто-нибудь еще взглянуть на код и найти один или два ярлыка, которые могли бы сделать его быстрее. Я предполагаю, что я слишком часто ссылаюсь на Рабочий лист в одном из циклов, но не смог найти хороший способ реструктуризации для повышения производительности.

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
```

0

Добавить комментарий

Ваш адрес email не будет опубликован. Обязательные поля помечены *