CODEWITHSUNDEEP
excelvbaexcel-formula
acr
acr

Reputation: 1746

Separate a column data into two based on text in one column

In my excel, C column always will have text either response or resolution . My goal is to separate A:C columns based on this. If C column has text response, Copy A:C column to E:G otherwise copy A:C to I:K

I am using below code now:

    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

This is working fine when I have less row in A:C. Now I have rows close to 20,000 and facing lot performance issues with excel. Is there anyway I can improve code to run it faster.

Upvotes: 0

Views: 51

Answers (1)

Naresh
Naresh

Reputation: 3034

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

First,

You can reduce your loop code like

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

Try Array: Arrays help reduce process time substantially.

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

With this timer ; I could check the process time. The first method is faster. May be because, it avoids storing and retrieving data from an array.

But if you just want separate tables as suggested by Ron Rosenfeld in his comment to the question, it is better to use autofilter. It will work faster than array.

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

Upvotes: 1

Related Questions