Home>

code
I create a table of products like a table in Excel.

A B C D E
Product code Product name Ingredient Ingredient ratio Update date
aaa Product A a 0.7 2020/1/10
aaa commodity A b 0.3 2020/1/10
bbb Product B c 0.5 2020/1/11
bbb Product B d 0.5 2020/1/11
ccc Product C f 1 2020/1/20
aaa Product A a 0.6 2020/3/5
aaa commodity A b 0.4 2020/3/5
ddd Product D a 0.4 March 12, 2020
ddd Product D f 0.6 March 12, 2020
ccc Product C s 1 2020/3/20

I adjusted the components in various ways and created the following code to move old data to another sheet.
(1) Sort by code and date.
(2) Store the code and date at the same code but different dates, and write the old version in column F.
③ Row F copies the old version row to another sheet and deletes it.
ソ ー ト Sort by date.

This works as expected, but it takes more than 20 minutes for more than 1000 data. I can only write this much code for beginners. Is there any way to speed it up? Thank you.
Environment: Excel2010, Windows7

Sub move ()
    Application.ScreenUpdating = False
    Dim txt As String, txt2 As String
    Dim i As Long, j As Long
    Dim ws As Worksheet, ws2 As Worksheet
    Set ws = Sheets ("Sheet1")
    Set ws2 = Sheets ("Sheet2")
    With ws.Sort
        With .SortFields
            .Clear
            .Add Key: = ws.Range ("A1"), Order: = xlAscending
            .Add Key: = ws.Range ("E1"), Order: = xlAscending
        End With
        .SetRange ws.Range ("A1: F"&Cells (Rows.Count, 1) .End (xlUp) .Row)
        .Header = xlYes
        .Apply
    End With
    With ws
        For i = 2 To .Cells (Rows.Count, 1) .End (xlUp) .Row
            If .Cells (i, 1) = .Cells (i + 1, 1) And .Cells (i, 5)<>.Cells (i + 1, 5) Then
                txt = .Cells (i, 1)
                txt2 = .Cells (i, 5)
                For j = 2 To .Cells (Rows.Count, 1) .End (xlUp) .Row
                    If .Cells (j, 1) = txt And .Cells (j, 5) = txt2 Then
                        .Cells (j, 6) = "Old version"
                    End If
                Next j
            End If
        Next i
    End With
    For i = ws.Cells (Rows.Count, 1) .End (xlUp) .Row To 2 Step -1
        If ws.Cells (i, 6) = "Old version" Then
            ws.Rows (i) .Copy
            Sheets ("Sheet2"). Select
            ws2.Rows (ws2.Cells (Rows.Count, 1) .End (xlUp) .Row) .Offset (1, 0) .Insert Shift: = xlDown
            ws.Rows (i) .Delete Shift: = xlUp
        End If
    Next i
    ws.Select
    With ws.Sort
        With .SortFields
            .Clear
            .Add Key: = ws.Range ("E1"), Order: = xlAscending
        End With
        .SetRange ws.Range ("A1: F"&Cells (Rows.Count, 1) .End (xlUp) .Row)
        .Header = xlYes
        .Apply
    End With
    Application.ScreenUpdating = True
End Sub
  • Answer # 1

      

    (1) Sort by code and date.
      (2) Store the code and date at the same code but different dates, and write the old version in column F.
      ③ Row F copies the old version row to another sheet and deletes it.
      ソ ー ト Sort by date.

    ① and ④ do not take much time and there will not be much speedup.

    It is expected that it will take some time in ② and ③.
    First, I considered the logic for speeding up ②.

    If the dates are in ascending order, scanning the loop backwards is likely to be simpler and faster.
    Boolean old version judgment variable,
    False if product code breaks (changes)
    The logic is to make it true if the date breaks.

    Sub move ()
        'Abbreviation ①
        With ws
            Dim old As Boolean ′ old version judgment
            For i = .Cells (Rows.Count, 1) .End (xlUp) .Row To 3 Step -1
                If .Cells (i, 1)<>.Cells (i-1, 1) Then 'Product code break
                    old = False
                ElseIf .Cells (i, 5)<>.Cells (i-1, 5) Then 'Update break
                    old = True
                End If
                If old Then .Cells (i-1, 6) = "Old version"
            Next i
        End With
        'Abbreviated ③ ④
    End Sub

    The copy/deletion of the old version of (3) is not performed line by line, but is limited to the data of the old version only with AutoFilter, and if you copy/delete it only once, it will be faster.

        With ws.Range ("A2: F"&ws.Cells (Rows.Count, 1) .End (xlUp) .Row)
            .AutoFilter Field: = 6, Criteria1: = "= old version"
            .Copy ws2.Range ("A2")
            .EntireRow.Delete
            .AutoFilter
        End With

    (2) I tried the old version judgment code using an array. I think that processing can be done on memory without cell reference, so it can be even faster.

        Dim rng As Range, ary () As Variant
        Set rng = ws.Range ("A2: F"&Cells (Rows.Count, 1) .End (xlUp) .Row)
        ary = rng.Value 'Store table data in array
        Dim old As Boolean
        For i = UBound (ary) To 2 Step -1
            If ary (i, 1)<>ary (i-1, 1) Then 'Product code break
                old = False
            ElseIf ary (i, 5)<>ary (i-1, 5) Then 'Update date break
                old = True
            End If
            If old Then ary (i-1, 6) = "Old version"
        Next irng.Columns (6) .Value = Application.Index (ary, 0, 6) 'Substitute the sixth column of the array into the sixth column of the table

  • Answer # 2

    Reduced the number of loops. I don't know how fast it will be, but what about?

    Sub test ()
        Dim txt As String, txt2 As String
        Dim i As Long, j As Long
        Dim ws As Worksheet, ws2 As Worksheet
        Set ws = Sheets ("Sheet1")
        Set ws2 = Sheets ("Sheet2")
        With ws.Sort
            With .SortFields
                .Clear
                .Add Key: = ws.Range ("A1"), Order: = xlAscending
                .Add Key: = ws.Range ("E1"), Order: = xlDescending
            End With
            .SetRange ws.Range ("A1: F"&Cells (Rows.Count, 1) .End (xlUp) .Row)
            .Header = xlYes
            .Apply
        End With
        With ws
            txt = .Cells (2, 1) .Value
            txt2 = .Cells (2, 5) .Value
            For i = 3 To .Cells (Rows.Count, 1) .End (xlUp) .Row
                If .Cells (i, 1) .Value<>txt Then
                    txt = .Cells (i, 1) .Value
                    txt2 = .Cells (i, 5) .Value
                ElseIf .Cells (i, 5) .Value<>txt2 Then
                    .Cells (i, 6) = "Old version"
                    ws.Rows (i) .Copy
                    ws2.Rows (ws2.Cells (Rows.Count, 1) .End (xlUp) .Row) .Offset (1, 0) .Insert Shift: = xlDown
                    ws.Rows (i) .Delete Shift: = xlUp
                    i = i-1
                End If
            Next i
        End With
    End Sub

    Since we have two For loops, why not just one?
    I have not verified it, but I think it will be as follows.

    If .Cells (j, 1) = txt And .Cells (j, 5) = txt2 Then
        .Cells (j, 6) = "Old version"
        .Rows (j) .Copy
        ws2.Rows (ws2.Cells (Rows.Count, 1) .End (xlUp) .Row) .Offset (1, 0) .Insert Shift: = xlDown
        .Rows (j) .Delete Shift: = xlUp
    End If

  • Answer # 3

    I tried using dictionay.
    I guess this is a single double loop.
    It will be as follows.

    Sub move ()
        Application.ScreenUpdating = False
        Dim txt As String, txt2 As String
        Dim i As Long, j As LongDim ws As Worksheet, ws2 As Worksheet
        Dim dicT As Object 'key Product code value: update date
        Dim key As Variant
        Set dicT = CreateObject ("Scripting.Dictionary") 'Define associative array
        Set ws = Sheets ("Sheet1")
        Set ws2 = Sheets ("Sheet2")
        With ws.Sort
            With .SortFields
                .Clear
                .Add key: = ws.Range ("A1"), Order: = xlAscending
                .Add key: = ws.Range ("E1"), Order: = xlAscending
            End With
            .SetRange ws.Range ("A1: F"&Cells (Rows.Count, 1) .End (xlUp) .row)
            .Header = xlYes
            .Apply
        End With
        With ws
            For i = .Cells (Rows.Count, 1) .End (xlUp) .row To 2 Step -1
                key = .Cells (i, 1)
                If dicT.exists (key) = True Then
                    If dicT (key)<>.Cells (i, 5) Then
                        .Cells (i, 6) = "Old version"
                    End If
                Else
                    dicT (key) = .Cells (i, 5)
                End If
            Next
        End With
        For i = ws.Cells (Rows.Count, 1) .End (xlUp) .row To 2 Step -1
            If ws.Cells (i, 6) = "Old version" Then
                ws.Rows (i) .Copy
                Sheets ("Sheet2"). Select
                ws2.Rows (ws2.Cells (Rows.Count, 1) .End (xlUp) .row) .Offset (1, 0) .Insert Shift: = xlDown
                ws.Rows (i) .Delete Shift: = xlUp
            End If
        Next i
        ws.Select
        With ws.Sort
            With .SortFields
                .Clear
                .Add key: = ws.Range ("E1"), Order: = xlAscending
            End With
            .SetRange ws.Range ("A1: F"&Cells (Rows.Count, 1) .End (xlUp) .row)
            .Header = xlYes
            .Apply
        End With
        Application.ScreenUpdating = True
    End Sub