VBA to scan each line for specific letters only returning columns C & E of C to I

[antinora]

Greetings: Here is a table of teacher data. In each cell is course code, course name, pass percentage, & department all in a single string. I plan on using Text-to-Column after I run the VBA below. The VBA (which I've used in the past) sets up a array of tabs, one for each department. The code then scans each line & populates each tab with cells containing the same department name using Case commands.

I've used this code for student class data & it has worked out to 9 columns.

When I run it with data below (in reality we have 168 teacher meaning 169 rows) the code only populates columns C & E for each tab. Also, it doesn't scan all rows.

I am unsure if my LBound to UBound is in error. Being a VBA novice I am unsure which command tells the VBA to scan each line.

Any help is appreciated by both me & my students. Thanks

John A.

Excel 2010

	A	B	C	D	E	F	G	H	I
TEACHER	CLASS1	CLASS2	CLASS3	CLASS4	CLASS5	CLASS6	CLASS7	CLASS8
ABBRUSCATO	MES33QQT/1-Common Core Algebra 3 Term 3 of 3-0.5454545455-Mathematics	MES41Q9C/1-Common Core Algebra 1 Term 1 of 4-0.7894736842-Mathematics	MES41QEL/1-Common Core Algebra 1 Term 1 of 4-0.4444444444-Mathematics	MES42Q9C/1-Common Core Algebra 1 Term 2 of 4-0.7894736842-Mathematics	MES42QEL/1-Common Core Algebra 1 Term 1 of 4-0.4444444444-Mathematics
AMALFITANO	PFS11/1-Fitness For Life-0.5957446809-Phys Ed	PFS11/2-Fitness For Life-0.5777777778-Phys Ed	PFS11/3-Fitness For Life-0.6744186047-Phys Ed	PGS11/4-Strength Training-0.72-Phys Ed	PGS11/6-Strength Training-0.6222222222-Phys Ed
ANDRE	EAS11QWR/1-Wilson Reading-0.6-ELA	EAS11QWR/2-Wilson Reading-0.8333333333-ELA	EAS11QWR/3-Wilson Reading-1-ELA	EES85QQM/1-English 5-0.7333333333-ELA	SLS21Q9S/13-Living Environment 1-1-Science	SLS21QLS/30-Living Environment 1 LAB-1-Science	ZY/2-Regents Skills-0.6-OSPAA
ANTHONY	SES21QLR/19-Earth Science 1 LAB-0.8095238095-Science	SES21QLR/9-Earth Science 1 LAB-0.5833333333-Science	SES21QLX/14-Earth Science 1 LAB-0.6818181818-Science	SES21QLX/3-Earth Science 1 LAB-0.8620689655-Science	SES21QQR/8-Earth Science 1-0.8571428571-Science	SES21QQR/9-Earth Science 1-0.8333333333-Science	SES21QQX/14-Earth Science 1-0.7727272727-Science	SES21QQX/3-Earth Science 1-0.8518518519-Science

<tbody>
[TD="align: center"]1[/TD]

[TD="align: center"]2[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]3[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]4[/TD]

[TD="align: right"][/TD]

[TD="align: center"]5[/TD]

</tbody>

Sheet1​

VBA:

Sub breakOut()Dim sh As Worksheet, c As Range, fn As Range, sAry As Variant
Set sh = Sheets("sheet1")
sAry = Array("ELA", "Mathematics", "Science", "Social Studies", "OSPAA", "Art", " Foreign Language", "Phys Ed")
    For i = LBound(sAry) To UBound(sAry)
        Sheets.Add After:=sh
        ActiveSheet.Name = sAry(i)
        sh.Range("A1:B1").Copy ActiveSheet.Range("A1")
        'ActiveSheet.Range("C1") = "Subj/Tchr"
        ActiveSheet.Columns("A:C").AutoFit
        For Each c In sh.Range("A2", sh.Cells(Rows.Count, 1).End(xlUp))
            Select Case sAry(i)
                Case "ELA"
                    ltr = "ELA"
                Case "Mathematics"
                    ltr = "Mathematics"
                Case "Science"
                    ltr = "Science"
                Case "Social Studies"
                    ltr = "Social Studies"
                Case "OSPAA"
                    ltr = "OSPAA"
                Case "Art"
                    ltr = "Art"
                Case "Foreign Language"
                    ltr = "Foreign Language"
                Case "Phys Ed"
                    ltr = "Phys Ed"
                                   
            End Select
            Set fn = c.Offset(, 3).Resize(1, 9).Find(ltr, , xlValues)
              If Not fn Is Nothing Then
                    Sheets(sAry(i)).Cells(Rows.Count, 1).End(xlUp)(2) = c.Value
                    Sheets(sAry(i)).Cells(Rows.Count, 1).End(xlUp).Offset(, 1) = c.Offset(, 1).Value
                    Sheets(sAry(i)).Cells(Rows.Count, 1).End(xlUp).Offset(, 2) = fn.Value
                End If
        Next
    Next
End Sub

 

[JLGWhiz]

What exactly do you want the code to do?

 

[Veritan]

Hello antinora, I believe this code will work for you. One thing I noticed when I was looking over your original code is that you appear to have your Sheet1 tab named "sheet1", with a lowercase s. This is fine, just so long as you're aware of it, since the default sheet name uses a capital S. The sheet name will need to match the code, whether it's a lowercase or uppercase S.

Sub BreakOut()
    Dim i%, sh As Worksheet, c As Range, fn As Range, sAry, FirstClass$, PasteRow%
    
    Application.ScreenUpdating = False
[COLOR=#008000]    'Lowercase "sheet1" in original code[/COLOR]
    Set sh = Sheets("Sheet1")
    sAry = Array("ELA", "Mathematics", "Science", "Social Studies", "OSPAA", "Art", " Foreign Language", "Phys Ed")
    For i = LBound(sAry) To UBound(sAry)
        Sheets.Add After:=sh
        ActiveSheet.Name = sAry(i)
        sh.Range("A1:I1").Copy ActiveSheet.Range("A1")

        For Each c In sh.Range("A2", sh.Cells(Rows.Count, 1).End(xlUp))
            Set fn = c.EntireRow.Find(sAry(i), LookIn:=xlValues, LookAt:=xlPart)
            If Not fn Is Nothing Then
                FirstClass = fn.Address
                PasteRow = Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
                Cells(PasteRow, 1) = c
                Do
                    Cells(PasteRow, fn.Column) = fn
                    If sAry(i) = "ELA" Or sAry(i) = "Art" Then
                        If Right(fn.Value, 3) <> sAry(i) Then Cells(PasteRow, fn.Column).ClearContents
                    End If
                    Set fn = c.EntireRow.FindNext(fn)
                Loop While Not fn Is Nothing And fn.Address <> FirstClass
                If WorksheetFunction.CountBlank(Cells(PasteRow, 2).Resize(, 8)) = 8 Then Cells(PasteRow, 1).ClearContents
            End If
        Next c
        Range("B2", Cells(Rows.Count, 1).End(xlUp).Offset(, 8)).WrapText = True
        Columns("B:I").ColumnWidth = 16
        ActiveSheet.Columns.AutoFit
        ActiveSheet.Rows.AutoFit
    Next i
    Application.ScreenUpdating = True
End Sub

I'm making some assumptions on how you want the data to appear. If this shows up in a format you don't want, can you provide specific details on how the information should appear? I also added some code for the ELA and Art departments to prevent them from matching false positives (the Art tab was getting classes with the word Earth in them, and I imagine ELA could run the same risk). Thank you, good luck with this!

 

[Veritan]

Sorry, just came up with a better way of preventing false positives. Try this code instead. This will only find a cell that matches the case of the department, "art" will not trigger "Art".

Sub BreakOut()
    Dim i%, sh As Worksheet, c As Range, fn As Range, sAry, FirstClass$, PasteRow%
    
    Application.ScreenUpdating = False
    'Lowercase "sheet1" in original code
    Set sh = Sheets("Sheet1")
    sAry = Array("ELA", "Mathematics", "Science", "Social Studies", "OSPAA", "Art", " Foreign Language", "Phys Ed")
    For i = LBound(sAry) To UBound(sAry)
        Sheets.Add After:=sh
        ActiveSheet.Name = sAry(i)
        sh.Range("A1:I1").Copy ActiveSheet.Range("A1")

        For Each c In sh.Range("A2", sh.Cells(Rows.Count, 1).End(xlUp))
            Set fn = c.EntireRow.Find(sAry(i), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
            If Not fn Is Nothing Then
                FirstClass = fn.Address
                PasteRow = Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
                Do
                    Cells(PasteRow, 1) = c
                    Cells(PasteRow, fn.Column) = fn
                    Set fn = c.EntireRow.FindNext(fn)
                Loop While Not fn Is Nothing And fn.Address <> FirstClass
            End If
        Next c
        Range("B2", Cells(Rows.Count, 1).End(xlUp).Offset(, 8)).WrapText = True
        Columns("B:I").ColumnWidth = 16
        ActiveSheet.Columns.AutoFit
        ActiveSheet.Rows.AutoFit
    Next i
    Application.ScreenUpdating = True
End Sub