How to Compare 2 columns align matches(retaining formuals) move columns 3 to 6 with column 2

How to compare 2 columns align matches (retaining formula) move columns 3 to 6 with column 2

Requirement:

The user has found the following macros that work perfectly, but they do not keep the formulas, only the text values. Either macro can be modified to answer the question.

The user would like them to keep the formulas in the cells.

This is the required result:

Compare Col B to Col A, align matches and keep Col C to F with Col B.

Col A, D and F contain formulas.

All columns have headings. Sorting is from row 2.

Col A has all the data and is sorted.

Col A to C do not contain blanks but D to F do contain blanks.

Col A contains more than 10 000 rows.

Code:

Sub AutoCat()
    Dim a, i As Long, ii As Long, w, txt
    a = Cells(1).CurrentRegion.Value
    ReDim w(1 To UBound(a, 2))
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If a(i, 2) <> "" Then
                txt = a(i, 2)
                For ii = 2 To UBound(a, 2)
                    w(ii) = a(i, ii)
                    a(i, ii) = ""
                Next
                .Item(txt) = w
            End If
        Next
        For i = 1 To UBound(a, 1)
            If .exists(a(i, 1)) Then
                For ii = 2 To UBound(a, 2)
                    a(i, ii) = .Item(a(i, 1))(ii)
                Next
            End If
        Next
    End With
    Cells(1).CurrentRegion.Value = a
End Sub

Code:

Sub AutoCat()
    Dim a, i As Long, ii As Long, w, x, n As Long
    With Range("a3").CurrentRegion
        a = .Value
        .ClearContents
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(a, 1)
                If a(i, 1) <> "" Then
                    If Not .exists(a(i, 1)) Then
                        ReDim w(1 To UBound(a, 2))
                        w(1) = a(i, 1): .Item(a(i, 1)) = w
                    End If
                End If
            Next
            For i = 1 To UBound(a, 1)
                If a(i, 2) <> "" Then
                    If Not .exists(a(i, 2)) Then
                        ReDim w(1 To UBound(a, 2))
                    Else
                        w = .Item(a(i, 2))
                    End If
                    For ii = 2 To UBound(a, 2)
                        w(ii) = a(i, ii)
                    Next
                    .Item(a(i, 2)) = w
                End If
            Next
            x = Application.Transpose(Application.Transpose(.items))
            n = .count
        End With
        .Resize(n).Value = x
    End With
End Sub

https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/1207231-compare-2-columns-align-matches-retaining-formuals-move-columns-3-to-6-with-column-2

Solution:

Code:

Sub AutoCatJVH()
Dim a As Variant, a1 As Variant, b As Variant, b1 As Variant, w() As String, r As Long, c As Long, txt As String
  With Range(Cells(1), Cells(1).End(xlDown))
    a1 = .Formula
    a = .Resize(, 2).Value2
    b1 = .Offset(, 2).Resize(, 4).FormulaR1C1
    ReDim b(1 To UBound(b1, 1), 1 To UBound(b1, 2))
    ReDim w(1 To UBound(a, 1))
    With CreateObject("Scripting.Dictionary")
      For r = 1 To UBound(a, 1)
        If a(r, 2) <> vbNullString Then
          txt = a(r, 2)
          w(r) = txt
          a(r, 2) = vbNullString
          .Item(txt) = r
        End If
      Next
      For r = 1 To UBound(a, 1)
        If .Exists(a(r, 1)) Then
          a(r, 2) = w(.Item(a(r, 1)))
          For c = 1 To UBound(b, 2)
            b(r, c) = b1(.Item(a(r, 1)), c)
          Next
        End If
      Next
    End With
    .Resize(, 2).Value2 = a
    .Formula = a1
    .Offset(, 2).Resize(, 4).FormulaR1C1 = b
  End With
End Sub

Using arrays (even five of them) like this is still much faster than iterating through range objects.

Obtained from the OzGrid Help Forum.

Solution provided by JonathanVH.