Code To Look For 2nd and 3rd Numbers And Move Entire Row To Seperate Sheets

[Dazzawm]

Hi I have sheet 1, column A with a list of numbers. What I need the code to do is look for the 2nd and 3rd numbers then move onto seperate sheets.

The numbers will be in the format of below and will always start with a letter:-

T125789
or
N302541

So in the above examples i would need the code to look for all the numbers with 25 in the list and move the entire row to 1 sheet then all the numbers with 02 and move to another shett and so on...

It would be helpful if the code created a sheet each time and named it the respective number.

Thanks

 

[Dazzawm]

I have tried using the Text To Columns function and used the fixed width option. I then did a sort by the 2 digits required and moved to another sheet but when I did a concatenate to put them together it kept leaving of a zero. For a example T1 22 047 became T12247? It appeared in the cell as 04 put when put together it became just a 4?

 

[Worf]

Hi

• Please test the code below. You´ll have to adjust ranges and sheet references. Special attention is to be paid to the formula, it refers to cell A2, so if it resides on E15, then:

15-13=2 and 5-4=1. This means that if your cell E15 is in use and the formula must go somewhere else, then the references must be adjusted.
Also,the cell above the formula must be empty,as my code does.

• If there is the possibility that a sheet with a two digit number already exists, for example one named “25” when you have data like T125789, tell me and I’ll modify the code.

Other things may go wrong depending on workbook structure, data layout or data itself, so I wait for your testing…

Sub CreateSheets()
Dim lr%, i%, j%, sh As Worksheet, cs(), ts$, sh2 As Worksheet, cc%


Set sh = Sheets("Sheet9")      ' type your sheet name here
j = 0
lr = sh.Range("a" & Rows.Count).End(xlUp).Row
' cell A1 is a header
For i = 2 To lr     ' assumes there are no sheets with two digits names
    ts = Mid(sh.Cells(i, 1).Value, 3, 2)
    If Not Exists(ts) Then
        j = j + 1
        ReDim Preserve cs(1 To j)
        cs(j) = ts
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = ts
    End If
Next


sh.Range("e14").Value = ""  ' assumes this cell is unused,change to suit


cc = sh.UsedRange.Columns.Count
For i = 1 To UBound(cs)
    sh.Range("e15").FormulaR1C1 = "=MID(R[-13]C[-4],3,2)=" & """" & Format(cs(i), "00") & """"
    Set sh2 = Sheets(cs(i))
    sh.Range(sh.Cells(1, 1), sh.Cells(lr, cc)).AdvancedFilter Action:=xlFilterCopy, _
    criteriarange:=sh.Range("e14:e15"), unique:=False, copytorange:=sh2.Range(sh2.Cells(1, 1), sh2.Cells(1, cc))
Next


End Sub


Function Exists(sn$) As Boolean


Dim ob As Object
On Error Resume Next
Set ob = ActiveWorkbook.Sheets(sn)
If err.Number = 0 Then Exists = True Else Exists = False


End Function

 

[Dazzawm]

I didn't really understand everything you said but it seemed to work great!! Thanks very much.

 

[Dazzawm]

HI worf this code is working great, just a slight amendment if possible please. When it looks for the 2nd and 3rd numbers the length of the data in each cell is 7 digits long. If there are any numbers in column A that are more or less than 7 then I need them all moved to a seperate sheet of their own named 'Misc' or something like that. Thanks.

Also when they are all seperated and put in there own respective sheets can the sheets be sorted in numerical order left to right please. Thanks.

 

[Worf]

Hi
Please test this. Important: the first row of the source table must have headers for the filter to work properly.

Sub CreateSheets()
Dim lr%, i%, sh As Worksheet, ts$, sh2 As Worksheet, cc%, cl As Collection


If Not Exists("Misc") Then
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "Misc"
End If
Set cl = New Collection
Set sh = Sheets("Sheet9")      ' type your sheet name here
lr = sh.Range("a" & Rows.Count).End(xlUp).Row
On Error Resume Next
For i = 2 To lr
    If Len(sh.Cells(i, 1).Value) = 8 Then
        ts = Mid(sh.Cells(i, 1).Value, 3, 2)
        If Not Exists(ts) Then
            Sheets.Add after:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = ts
        End If
        cl.Add ts, CStr(ts)
    End If
Next
On Error GoTo 0
sh.Range("b" & (lr + 1)).Value = ""
cc = sh.UsedRange.Columns.Count


For i = 1 To cl.Count
    sh.Range("b" & (lr + 2)).FormulaR1C1 = "=AND(MID(R[-" & lr & "]C[-1],3,2)=" & """" & _
    Format(cl(i), "00") & """" & ",LEN(R[-" & lr & "]C[-1])=8)"
    Set sh2 = Sheets(cl(i))
    sh.Range(sh.Cells(1, 1), sh.Cells(lr, cc)).AdvancedFilter Action:=2, criteriarange:= _
    sh.Range("b" & (lr + 1) & ":b" & (lr + 2)), unique:=False, copytorange:=sh2.Range(sh2.Cells(1, 1), sh2.Cells(lr, cc))
Next


sh.Range("b" & (lr + 2)).FormulaR1C1 = "=LEN(R[-" & lr & "]C[-1])<>8"
Set sh2 = Sheets("Misc")
sh.Range(sh.Cells(1, 1), sh.Cells(lr, cc)).AdvancedFilter xlFilterCopy, sh.Range("b" & (lr + 1) & ":b" & (lr + 2)), _
sh2.Range(sh2.Cells(1, 1), sh2.Cells(lr, cc)), False
Alph
End Sub


Function Exists(sn$) As Boolean
    Dim ob As Object
    On Error Resume Next
    Set ob = ActiveWorkbook.Sheets(sn)
    If err.Number = 0 Then Exists = True Else Exists = False
End Function


Sub Bubblesort(sht())
    Dim tmp, i%, j%
    For i = LBound(sht) To UBound(sht)
        For j = i To UBound(sht)
            If sht(i) > sht(j) Then
                tmp = sht(i)
                sht(i) = sht(j)
                sht(j) = tmp
            End If
        Next j
    Next i
End Sub


Sub Alph()
    Dim sht As Worksheet, Shts(), i%, ns%
    ns = Sheets.Count
    ReDim Shts(ns)
    i = LBound(Shts)
    For Each sht In ThisWorkbook.Worksheets
        Shts(i) = sht.Name
        i = i + 1
    Next sht
    Bubblesort Shts
    For i = LBound(Shts) + 1 To UBound(Shts)
        Worksheets(Shts(i)).Move after:=Worksheets(ns)
    Next i
End Sub

 

[Dazzawm]

Thanks Worf the splitting up works great. Although when it goes to sort all the sheets I get a debug at

Worksheets(Shts(i)).Move after:=Worksheets(ns)

 

[Worf]

Hmmmm, it worked fine with my sample workbook.</SPAN></SPAN>

• What is the error message?</SPAN></SPAN></SPAN>
• With the yellow error bar on, what values do you get when placing the mouse pointer over Shts(i) and ns?</SPAN></SPAN></SPAN>
• If you can email me a problematic workbook I’ll take a look at the real thing. No need for real data, just the sorting problem must be there.</SPAN></SPAN></SPAN>

 

[Dazzawm]

Its no big deal, the splitting of the sheets is the main thing which works fine. I have a seperate code that will sort the sheets. Thanks for your help. If you still want it for your own peace of mind I will have to send tomorrow when back at work.

 

[Worf]

If everything is working, then let’s leave it alone…

Needing further help on this subject, please post here.