Macro to sort data in an Array

[porterrm]

Hi

I am looking to sorta data set that is about 10,000 rows by 6 columns and I need help writing asimple macro

I made an example to illustrate what I am looking for.

I want to search the first column of data in Table 1and look for all rows that contain the letter "a" and put all of those rows in a new Table 2. Then it does the same thing for rows that contain the letter "b" and then "c". In the end I would have three separate tables with the data sorted.

​

Table 1		Table 2		Table 3		Table 4
X	y	Z		X	y	Z		X	y	Z		X	y	Z
a1	1	4		a1	1	4		b1	2	3		c1	3	2
b1	2	3		a2	1	4		b2	2	3		c2	3	2
c1	3	2
a2	1	4
b2	2	3
c2	3	2

<tbody>
</tbody>

I did somethingsimilar to this years ago with arrays. Put all the data from the original tablein an Array and the with an if statement loop through the array and then it populated "a" array, "b" array and a "c" array. Once thatwas done it printed them out to designated cells.

If anyone has anyrecommendations or can point me to a thread I missed(I looked but am relativelynew to the site) I would appreciate it.

Thank you and I appreciate the help

Porter

 

[wideboydixon]

Start:

Book1
	A	B	C
1	X	y	Z
2	a1	1	4
3	b1	2	3
4	c1	3	2
5	a2	1	4
6	b2	2	3
7	c2	3	2
Sheet1

Macro:

Public Sub SplitTable()

Dim lastRow As Long
Dim thisRow As Long
Dim nextRow(2) As Long
Dim tableNum As Long

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range(Range("D1"), Cells(lastRow, "O")).ClearContents
For tableNum = 0 To 2
    nextRow(tableNum) = 2
    Range(Cells(1, tableNum * 4 + 5), Cells(1, tableNum * 4 + 7)).Value = Range("A1:C1").Value
Next tableNum

For thisRow = 2 To lastRow
    Select Case Left(Cells(thisRow, "A").Value, 1)
        Case "a"
            tableNum = 0
        Case "b"
            tableNum = 1
        Case "c"
            tableNum = 2
        Case Else
            tableNum = 4
    End Select
    
    If tableNum < 4 Then
        Range(Cells(nextRow(tableNum), tableNum * 4 + 5), Cells(nextRow(tableNum), tableNum * 4 + 7)).Value = Range("A" & thisRow & ":C" & thisRow).Value
        nextRow(tableNum) = nextRow(tableNum) + 1
    End If
Next thisRow

End Sub

End:

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	X	y	Z		X	y	Z		X	y	Z		X	y	Z
2	a1	1	4		a1	1	4		b1	2	3		c1	3	2
3	b1	2	3		a2	1	4		b2	2	3		c2	3	2
4	c1	3	2
5	a2	1	4
6	b2	2	3
7	c2	3	2
Sheet1

WBD

 

[MickG]

Another option:- Data as per your Thread, actual data starts row 2.
Results every forth column

[COLOR="Navy"]Sub[/COLOR] MG22Aug05
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, t [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray() [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Fd [COLOR="Navy"]As[/COLOR] Boolean
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] n = 97 To 122
c = 2: Fd = False
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
       
        [COLOR="Navy"]If[/COLOR] Left(Dn.Value, 1) = Chr(n) [COLOR="Navy"]Then[/COLOR]
            Fd = True
            c = c + 1
            ReDim Preserve Ray(1 To 3, 1 To c)
            Ray(2, 1) = "Table "
            Ray(1, c) = Dn.Value
            Ray(2, c) = Dn.Offset(, 1).Value
            Ray(3, c) = Dn.Offset(, 2).Value
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
    [COLOR="Navy"]If[/COLOR] Fd [COLOR="Navy"]Then[/COLOR]
        t = t + 1
        col = col + 4
        Ray(2, 1) = "Table " & t
        Ray(1, 2) = Rng(1)
        Ray(2, 2) = Rng(1).Offset(, 1).Value
        Ray(3, 2) = Rng(1).Offset(, 1).Value
        [COLOR="Navy"]With[/COLOR] Cells(1, col + 1).Resize(c, 3)
            .Value = Application.Transpose(Ray)
            .HorizontalAlignment = xlCenter
        [COLOR="Navy"]End[/COLOR] With
         Erase Ray
    
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[porterrm]

I tried both of these options and they both worked great. Thanks for the quick response!

 

[MickG]

You're welcome

 

[Peter_SSs]

Welcome to the MrExcel board!

.. yet another option to try

Sub Make_Tables()
  Dim itm As Variant
  
  For Each itm In Split("a b c")
    Range("ZZ2").Formula = "=search(""" & itm & """,A2)"
    Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("ZZ1:ZZ2"), CopyToRange:=Cells(1, Columns.Count).End(xlToLeft).Offset(, 2), Unique:=False
  Next itm
  Range("ZZ2").ClearContents
End Sub

 

[porterrm]

Hi Peter,
Hi Peter,

Thanks for the post. Would you mind providing some commentsfor your code? This seems like a really clean was of solving this problem but Iam having a hard time following it. Thanks!

Porter

 

[Peter_SSs]

Would you mind providing some commentsfor your code?

Hmm, there isn't a lot of explanation to include, but here goes ..

Sub Make_Tables()
  Dim itm As Variant
  
  'For each item that you want to search for in column A
  For Each itm In Split("a b c")
    'Put an Advanced Filter criteria formula in an empty column
    Range("ZZ2").Formula = "=search(""" & itm & """,A2)"
    'Do an Advanced Filter using that formula & writing the results offset to the right
    Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("ZZ1:ZZ2"), CopyToRange:=Cells(1, Columns.Count).End(xlToLeft).Offset(, 2), Unique:=False
  Next itm
  'Clear the Advanced Filter criteria formula
  Range("ZZ2").ClearContents
End Sub