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

tony0217

Board Regular
Joined
Aug 31, 2012
Messages
134
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.




Code:
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
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
An explanation of what you are trying to do along with some sample data would help you get an answer. ;)
 
Upvote 0
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.

Code:
             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
 
Last edited:
Upvote 0
How about
Code:
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
 
Upvote 0
Which line of code gave that error?
 
Upvote 0
Sounds like there were no matches, add this line
Code:
   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?
 
Upvote 0
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 _
 
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,040
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top