vba for identifying strings of data and moving large sets of data

[tony0217]

i have this vba code that ive been working on since last year and i cant seem to run it without excel crashing when i add more data to it.
is there any way to tidy this up or make it run more efficiently (faster)?

i have 100 rows x 6 columns but sometimes up to 15 columns wide.

I just cant seem to speed it up. please help. thanks in advance.

Sub Permute()
Application.ScreenUpdating = False
Dim ix(100, 1) As Long, rc As Long, m As Long, br As Long, md As Variant, i As Long, r As Long
Dim str1 As String, r1 As Long, c1 As Long, element(100) As Variant


    rc = Cells(1, Columns.Count).End(xlToLeft).Column
    m = 0
    For i = 1 To rc
        br = Cells(Rows.Count, i).End(xlUp).Row
        If br > m Then m = br
        ix(i, 0) = br
        ix(i, 1) = 1
    Next i
    md = Range(Cells(1, 1), Cells(m, rc)).Value
    r = 0
Incr:
    str1 = ""
    For i = 1 To rc
        str1 = str1 & md(ix(i, 1), i)
        element(i) = md(ix(i, 1), i)
    Next i


MyCode:
    If Mid(element(1), 1, 1) = Mid(element(2), 1, 1) And _
    Mid(element(1), 1, 1) = Mid(element(3), 1, 1) And _
    Mid(element(2), 1, 1) = Mid(element(3), 1, 1) And _
    Mid(element(1), 2, 1) = Mid(element(4), 1, 1) And _
    Mid(element(1), 2, 1) = Mid(element(5), 1, 1) And _
    Mid(element(4), 1, 1) = Mid(element(5), 1, 1) And _
    Mid(element(2), 2, 1) = Mid(element(4), 2, 1) And _
    Mid(element(2), 2, 1) = Mid(element(6), 1, 1) And _
    Mid(element(4), 2, 1) = Mid(element(6), 1, 1) And _
    Mid(element(3), 2, 1) = Mid(element(5), 2, 1) And _
    Mid(element(3), 2, 1) = Mid(element(6), 2, 1) And _
    Mid(element(5), 2, 1) = Mid(element(6), 2, 1) Then _


        r = r + 1
        r1 = ((r - 1) Mod Rows.Count) + 1
        c1 = Int((r - 1) / Rows.Count) + 1
        Sheets("Sheet2").Cells(r1, c1) = str1
    End If
    
    For i = rc To 1 Step -1
        ix(i, 1) = ix(i, 1) + 1
        If ix(i, 1) <= ix(i, 0) Then Exit For
        ix(i, 1) = 1
    Next i
    If i > 0 Then GoTo Incr:
    
End Sub

 

[tony0217]

any takers?

 

[Fluff]

An explanation of what you are trying to do along with some sample data would help you get an answer.

 

[tony0217]

i have 6-15 columns
each column contains a list.
each column is approximately 100 rows long.
each value in each cell contains 2 numbers separated by a space from 00-99.

             A    B    C   

          A B   B C  A C
ROW 1     0 2   2 5   0 5 
ROW 2     4 5   6 3   8 4
ETC...

with this information i then want to compare the second character
of cell A1 with the first character of cell b1.

then the first character of A1 with the first character of c1
then the second character of b1 with the second character of c1.


if all 3 do not match, then discard.
now if all three characters match in all three scenarios i want to copy the values from cells a1, b1, and c1 to the next available spot on sheet2

 

[Fluff]

How about

Sub Permute()
   Dim Ary As Variant
   Dim Nary() As Variant
   Dim a As Variant
   Dim i As Long, r As Long, c As Long
   
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   For i = 1 To UBound(Ary)
      If Trim(Right(Ary(i, 1), 2)) = Trim(Left(Ary(i, 2), 2)) And _
         Trim(Left(Ary(i, 1), 2)) = Trim(Left(Ary(i, 3), 2)) And _
         Trim(Right(Ary(i, 2), 2)) = Trim(Right(Ary(i, 3), 2)) Then
            r = r + 1
            For c = 1 To UBound(Ary, 2)
               Nary(r, c) = Ary(i, c)
            Next c
      End If
   Next i
   Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(r, UBound(Nary, 2)).Value = Nary

 

[tony0217]

i recieved the application defined or object defined error.

 

[Fluff]

Which line of code gave that error?

 

[tony0217]

it happens on the last line of code

 

[Fluff]

Sounds like there were no matches, add this line

   Next i
   [COLOR=#ff0000]If r = 0 Then MsgBox "No Matches": Exit Sub[/COLOR]
   Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(r, UBound(Nary, 2)).Value = Nary

Does the message box appear?

 

[tony0217]

i added the line and no matter how many rows of data i input, i do not get any matches. there should be at least one but none are showing up on page two.
here are the matches that i want to keep.




If Mid(element(1), 1, 1) = Mid(element(2), 1, 1) And _
Mid(element(1), 1, 1) = Mid(element(3), 1, 1) And _
Mid(element(2), 1, 1) = Mid(element(3), 1, 1) And _
Mid(element(1), 2, 1) = Mid(element(4), 1, 1) And _
Mid(element(1), 2, 1) = Mid(element(5), 1, 1) And _
Mid(element(4), 1, 1) = Mid(element(5), 1, 1) And _
Mid(element(2), 2, 1) = Mid(element(4), 2, 1) And _
Mid(element(2), 2, 1) = Mid(element(6), 1, 1) And _
Mid(element(4), 2, 1) = Mid(element(6), 1, 1) And _
Mid(element(3), 2, 1) = Mid(element(5), 2, 1) And _
Mid(element(3), 2, 1) = Mid(element(6), 2, 1) And _
Mid(element(5), 2, 1) = Mid(element(6), 2, 1) Then _