Data migration between tabs using VBA

[polishfc]

Hi All,

As an overview, I have a spreadsheet built with a few macros that copies raw data from one tab and pastes it into other tabs based on the status. Both the raw data and the data in the other tabs contain both current and historic line items so I have code in place that only runs the “copy-paste” code if an ID is new and unique. Now that the dataset has grown the macro is excruciatingly slow, so I would like to get your opinion/critique on how to make it more efficient

I’ve put together a rudimentary sample set and basically copy and pasted the VBA code from my actual dataset to run off of the command button in the “Raw Data” tab.

Quick explanation of how the macro is ideally supposed to work:

Scans through the “Open” tab flags any line items with unique ID Numbers in the “Raw Data” tab than copy and paste cells to certain columns (as the columns between the two tabs do not line up)

Any help is greatly appreciated. Thanks.

[Paul_Hossler]

I think that the looping was adding the extra run time

See if something like this is faster

Future -- if new data is ALWAYS added to the end of Data, then it would be much faster if there's a lot of data to check from bottom (newest data) going up and adding data to the sheets until a match is found and then just exit everything

Option Explicit


'columns in Data sheet
Const colID As Long = 1
Const colStatus As Long = 2
Const colName As Long = 3
Const colJob As Long = 4
Const colHours As Long = 5
Const colOffice As Long = 6


Public Sub CheckNewRecordOpenTest()
    Dim wsData As Worksheet
    Dim wsOpen As Worksheet, wsClosed As Worksheet, wsFilled As Worksheet
    Dim n As Long, iData As Long, iNew As Long
    Dim intsh2Row As Integer
    
    Set wsData = Worksheets("Raw Data")
    Set wsOpen = Worksheets("Open")
    Set wsClosed = Worksheets("Closed")
    Set wsFilled = Worksheets("Filled")


    With wsData
        For iData = 2 To .Cells(1, 1).CurrentRegion.Rows.Count
            Select Case LCase(.Cells(iData, colStatus).Value)
                
                '  1              2        3       4          5        6
                'Name    Job Description Hours   Office  ID Number   Status
                Case "open"
                    n = 0
                    On Error Resume Next
                    n = Application.WorksheetFunction.Match(.Cells(iData, colID).Value, wsOpen.Columns(5), 0)
                    On Error GoTo 0
                    
                    If n = 0 Then       '   new one so add to end
                        iNew = wsOpen.Cells(wsOpen.Rows.Count, 5).End(xlUp).Row + 1
                                    
                        wsOpen.Cells(iNew, 1).Value = .Cells(iData, colName).Value
                        wsOpen.Cells(iNew, 2).Value = .Cells(iData, colJob).Value
                        wsOpen.Cells(iNew, 3).Value = .Cells(iData, colHours).Value
                        wsOpen.Cells(iNew, 4).Value = .Cells(iData, colOffice).Value
                        wsOpen.Cells(iNew, 5).Value = .Cells(iData, colID).Value
                        wsOpen.Cells(iNew, 6).Value = "Open"
                    End If


                '   1          2                3                4         5          6
                'Status  Name    Job Description Hours   Office  ID Number
                Case "closed"
                    n = 0
                    On Error Resume Next
                    n = Application.WorksheetFunction.Match(.Cells(iData, colID).Value, wsClosed.Columns(6), 0)
                    On Error GoTo 0
                    
                    If n = 0 Then       '   new one so add to end
                        iNew = wsClosed.Cells(wsClosed.Rows.Count, 5).End(xlUp).Row + 1
                                    
                        wsClosed.Cells(iNew, 1).Value = "Closed"
                        wsClosed.Cells(iNew, 2).Value = .Cells(iData, colName).Value
                        wsClosed.Cells(iNew, 3).Value = .Cells(iData, colJob).Value
                        wsClosed.Cells(iNew, 4).Value = .Cells(iData, colHours).Value
                        wsClosed.Cells(iNew, 5).Value = .Cells(iData, colOffice).Value
                        wsClosed.Cells(iNew, 6).Value = .Cells(iData, colID).Value
                    End If
            
                '      1             2          3     4        5       6
                'Job Description ID Number   Status  Name    Hours   Office
                Case "filled"
                    n = 0
                    On Error Resume Next
                    n = Application.WorksheetFunction.Match(.Cells(iData, colID).Value, wsFilled.Columns(2), 0)
                    On Error GoTo 0
                    
                    If n = 0 Then       '   new one so add to end
                        iNew = wsFilled.Cells(wsFilled.Rows.Count, 5).End(xlUp).Row + 1
                                    
                        wsFilled.Cells(iNew, 1).Value = .Cells(iData, colJob).Value
                        wsFilled.Cells(iNew, 2).Value = .Cells(iData, colID).Value
                        wsFilled.Cells(iNew, 3).Value = "Filled"
                        wsFilled.Cells(iNew, 4).Value = .Cells(iData, colName).Value
                        wsFilled.Cells(iNew, 5).Value = .Cells(iData, colHours).Value
                        wsFilled.Cells(iNew, 6).Value = .Cells(iData, colOffice).Value
                    End If
            End Select
        Next iData
    End With


End Sub