Разделите данные столбца на две части на основе текста в одном столбце.

Question

В моем Excel столбец C всегда будет иметь текст response или resolution. Моя цель - разделить столбцы A: C на основе этого. Если в столбце C есть текст response, скопируйте столбец A: C в E:G, в противном случае скопируйте A:C в I:K

Я сейчас использую код ниже:

    Sub SLACalc()
    Dim DTA As Workbook
    Dim SLADATA As Worksheet

    Set DTA = Excel.Workbooks("main.xlsm")
    Set SLADATA = DTA.Worksheets("SLA DATA")

    For i = 2 To SLADATA.Cells(Rows.Count, "A").End(xlUp).Row

        If InStr(Cells(i, "C").Value, "response") > 0 Then

            SLADATA.Cells(i, "E").Value = SLADATA.Cells(i, "A").Value
            SLADATA.Cells(i, "F").Value = SLADATA.Cells(i, "B").Value
            SLADATA.Cells(i, "G").Value = SLADATA.Cells(i, "C").Value

         Else

            SLADATA.Cells(i, "I").Value = SLADATA.Cells(i, "A").Value
            SLADATA.Cells(i, "J").Value = SLADATA.Cells(i, "B").Value
            SLADATA.Cells(i, "K").Value = SLADATA.Cells(i, "C").Value

        End If
    Next i

End Sub

Это нормально работает, когда у меня меньше строк в A:C. Теперь у меня есть ряды, близкие к 20 000, и я столкнулся с большим количеством проблем с производительностью в Excel. Могу ли я улучшить код, чтобы ускорить его выполнение?

Answer 1

Assuming you want to split the table on the same row as per you code

First,

Вы можете уменьшить свой код l oop, например

For i = 2 To SLADATA.Cells(Rows.Count, "A").End(xlUp).Row
    If InStr(Cells(i, "C").Value, "response") > 0 Then
        SLADATA.Range(Cells(i, "E"), Cells(i, "G")).Value = SLADATA.Range(Cells(i, "A"), Cells(i, "C")).Value
     Else
        SLADATA.Range(Cells(i, "I"), Cells(i, "K")).Value = SLADATA.Range(Cells(i, "A"), Cells(i, "C")).Value
    End If
Next i

Second

Попробуйте Массив: Массивы помогают существенно сократить время процесса.

Sub SLACalc2()
    Dim DTA As Workbook
    Dim SLADATA As Worksheet
    Set DTA = Excel.Workbooks("main.xlsm")
    Set SLADATA = DTA.Worksheets("SLA DATA")
    LRow = SLADATA.Cells(Rows.Count, "A").End(xlUp).Row
    DataArr = SLADATA.Range("A2:C" & LRow).Value

    For i = 1 To UBound(DataArr)
        If Application.Index(DataArr, i, 3) = "response" Then
            SLADATA.Range(Cells(i + 1, "E"), Cells(i + 1, "G")).Value = Application.Index(DataArr, i)
         Else
            SLADATA.Range(Cells(i + 1, "I"), Cells(i + 1, "K")).Value = Application.Index(DataArr, i)
        End If
    Next i

End Sub

При этот таймер ; Я мог бы проверить время процесса. Первый способ быстрее. Может быть потому, что он избегает хранения и извлечения данных из массива.

Но если вам просто нужны отдельные таблицы, как предложил Рон Розенфельд в своем комментарии к вопросу, лучше использовать автофильтр. Он будет работать быстрее, чем массив.

Sub Macro1()
    Dim DataRng As Range
    Set DataRng = Range("A1:C" & Cells(Rows.Count, "A").End(xlUp).Row)

    DataRng.AutoFilter Field:=3, Criteria1:="=*response*"
    DataRng.Cells.SpecialCells(xlCellTypeVisible).Copy
    Range("E1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

    DataRng.AutoFilter Field:=3, Criteria1:="=*resolution*"
    DataRng.Cells.SpecialCells(xlCellTypeVisible).Copy
    Range("I1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

    ActiveSheet.ShowAllData

End Sub