Combine Columns with Filter - Existing Macro

[JSpectrum]

Hello,

I have this macro that will combine a column based on matching data in specified columns. However, the macro (below) misbehaves when the data has an auto filter on it. Is there a way to modify this macro so that it will recognize the filtered data?

Thank you for your help!

Sub CombineLikeExams() 
    Dim a, txt As String, i As Long, ii As Long, n As Long 
    With Range("b2").CurrentRegion 
        a = .Value 
        .ClearContents 
        With CreateObject("Scripting.Dictionary") 
            .CompareMode = 1 
            For i = 1 To UBound(a, 1) 
                txt = Join$(Array(a(i, 2), a(i, 3), a(i, 4)), ";;") 
                If Not .exists(txt) Then 
                    n = n + 1 
                    For ii = 1 To UBound(a, 2) 
                        a(n, ii) = a(i, ii) 
                    Next 
                    .Item(txt) = n 
                Else 
                    a(.Item(txt), 5) = a(.Item(txt), 5) & ", " & a(i, 5) 
                End If 
            Next 
        End With 
        .Resize(n).Value = a 
    End With 
End Sub 

[trunten]

Quickest way would be to clear the filter first like so:

If Not ActiveSheet.AutoFilter Is Nothing Then 
    ActiveSheet.AutoFilter.ShowAllData 
End If 

[jindon]

That code ignores Filters.

What are you trying to do?

[JSpectrum]

The macro will combine the data in column F if column D, E and H matches. I need to be able to filter the data, then run the macro without it pulling any data from the hidden rows that aren't needed in the filter.

[jindon]

Not tested

If this doesn't work, I need to see the file

Sub CombineLikeExams() 
    Dim r As Range, txt As String, a,ii As Long 
    With Range("b2").CurrentRegion.Offset(1) 
        Redim a(1 To .Rows.Count, 1 To Columns.Count) 
        With CreateObject("Scripting.Dictionary") 
            .CompareMode = 1 
            For Each r In .Columns(1).SpecialCells(12) 
                txt = Join$(Array(r(,2).value, r(,3).value, r(,4).value), ";;") 
                If Not .exists(txt) Then 
                    n = n + 1 
                    For ii = 1 To UBound(a, 2) 
                        a(n, ii) = r(,ii).Value 
                    Next 
                    .Item(txt) = n 
                Else 
                    a(.Item(txt), 5) = a(.Item(txt), 5) & ", " & r(,5).value 
                End If 
            Next 
        End With 
        .Offset(,.Columns.Count + 2).resize(n,UBound(a,2)).value = a 
    End With 
End Sub 

[JSpectrum]

It gave an error Run Time Error '7' Out of Memory on this line...

Redim a(1 To .Rows.Count, 1 To Columns.Count) 

[jindon]

Missed a period

Redim a(1 To .Rows.Count, 1 To .Columns.Count) 

[JSpectrum]

Hah, yes, I noticed that and added the period. Then it proceeded with an error (Object doesn't support this project or method) on this line.

For Each r In .Columns(1).SpecialCells(12) 

[jindon]

Of course...

Sub CombineLikeExams() 
    Dim r As Range, txt As String, a 
    Dim dic As Object 
    Set dic = CreateObject("Scripting.Dictionary") 
    dic.CompreMOde = 1 
    With Range("b2").CurrentRegion.Offset(1) 
        Redim a(1 To .Rows.Count, 1 To .Columns.Count) 
        For Each r In .Columns(1).SpecialCells(12) 
            txt = Join$(Array(r(,2).value, r(,3).value, r(,4).value), ";;") 
            If Not dic.exists(txt) Then 
                n = n + 1 
                For ii = 1 To .Columns.Count 
                    a(n, ii) = r(,ii).Value 
                Next 
                dic(txt) = n 
            Else 
                a(dic(txt), 5) = a(dic(txt), 5) & ", " & r(,5).value 
            End If 
        Next 
        .Offset(,.Columns.Count + 2).resize(n,UBound(a,2)).value = a 
    End With 
End Sub 

[JSpectrum]

Object doesn't support this project or method on this line

dic.CompreMOde = 1