i need vba or simple vb6 application to create every classes name with student names

[muhmath2002]

hi all
i have exported excel file contains student names and classes names
i need vba or simple vb6 form application to:
1. open excel file
2. filter every class name with students names sorted ascending
3. create sheets with same class names this is option1
4. create excels files separated with name of class names and name sheets is class names option2
exported excel file from link

student name class

MediaFire is a simple to use free service that lets you put all your photos, documents, music, and video in a single place so you can access them anywhere and share them everywhere.

www.mediafire.com

best regards

 

[maabadi]

What about Empty Cells at Class Names?

 

[maabadi]

I use Column C to F and your Data sheet for Helper at VBA. if you need them , I can change address to Last columns.
1. First Input this formula at Cell D2 then Drag it down. (Because your name is Arabic and don't recognize at VBA)

=IFNA(VLOOKUP(B2,$E$2:$F$60,2,FALSE),"")

2. try this:

Sub ExtractStudents()
Dim d As Object, c As Variant, i As Long, lr As Long, ws As Worksheet, lr2 As Long, WS2 As Worksheet
Dim a As Long, j As Long, e As Long
Set ws = Sheets("data")
Set d = CreateObject("Scripting.Dictionary")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort , key1:=Range("A2:A" & lr), order1:=xlAscending, Header:=xlNo
c = Range("B2:B" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
ws.Range("E1").Value = "Unique"
ws.Range("E2").Resize(d.Count) = Application.Transpose(d.keys)
lr2 = ws.Cells(Rows.Count, 5).End(xlUp).Row
Range("E2:E" & lr2).Sort , key1:=Range("E2:E" & lr2), order1:=xlAscending, Header:=xlNo
For i = 2 To lr2
ws.Range("F" & i) = i - 1
Next i
For i = 2 To lr2
If ws.Cells(i, 5).Value <> "" Then
   a = Application.WorksheetFunction.CountIf(ws.Range("D2:D" & lr), ws.Cells(i, 6))
    For j = 2 To lr
    If ws.Cells(j, 2).Value <> "" Then
   ws.Cells(j, 3).Value = Application.WorksheetFunction.CountIf(ws.Range("D2:D" & j), ws.Range("F" & i))
    End If
    Next j
     Sheets.Add(After:=Sheets(Sheets.Count)).Name = ws.Cells(i, 5).Value
     Cells(1, 3).Value = ws.Cells(i, 5).Value
     For j = 2 To a + 1
     Range("A" & j).Value = Application.WorksheetFunction.Index(ws.Range("A2:A" & lr), Application.WorksheetFunction.Match(j - 1, ws.Range("C2:C" & lr), 0), 1)
     Next j
     Range("A2:A" & a + 1).Sort , key1:=Range("A2:A" & a + 1), order1:=xlAscending, Header:=xlNo
     Columns("A").AutoFit
End If
Next i
End Sub

 

[maabadi]

Sorry my Code has Problems Use this.
I use Column C to F and your Data sheet for Helper at VBA. if you need them , I can change address to Last columns.
1. First Input this formula at Cell D2 then Drag it down. (Because your name is Arabic and don't recognize at VBA)

=IFNA(VLOOKUP(B2,$E$2:$F$60,2,FALSE),"")

Try this Modified Macro:

Sub ExtractStudents()
Dim d As Object, c As Variant, i As Long, lr As Long, ws As Worksheet, lr2 As Long, WS2 As Worksheet
Dim a As Long, j As Long, e As Long
Set ws = Sheets("data")
Set d = CreateObject("Scripting.Dictionary")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort , key1:=Range("B2:B" & lr), order1:=xlAscending, key2:=Range("A2:A" & lr), order2:=xlAscending, Header:=xlNo
c = Range("B2:B" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
ws.Range("E1").Value = "Unique"
ws.Range("E2").Resize(d.Count) = Application.Transpose(d.keys)
lr2 = ws.Cells(Rows.Count, 5).End(xlUp).Row
Range("E2:E" & lr2).Sort , key1:=Range("E2:E" & lr2), order1:=xlAscending, Header:=xlNo
For i = 2 To lr2
ws.Range("F" & i) = i - 1
Next i
For i = 2 To lr2
If ws.Cells(i, 5).Value <> "" Then
   a = Application.WorksheetFunction.CountIf(ws.Range("D2:D" & lr), ws.Cells(i, 6))
    For j = 2 To lr
    If ws.Cells(j, 2).Value <> "" Then
   ws.Cells(j, 3).Value = Application.WorksheetFunction.CountIf(ws.Range("D2:D" & j), ws.Range("F" & i))
    End If
    Next j
     Sheets.Add(After:=Sheets(Sheets.Count)).Name = ws.Cells(i, 5).Value
     Cells(1, 3).Value = ws.Cells(i, 5).Value
     For j = 2 To a + 1
     Range("A" & j).Value = Application.WorksheetFunction.Index(ws.Range("A2:A" & lr), Application.WorksheetFunction.Match(j - 1, ws.Range("C2:C" & lr), 0), 1)
     Next j
     Range("A2:A" & a + 1).Sort , key1:=Range("A2:A" & a + 1), order1:=xlAscending, Header:=xlNo
     Columns("A").AutoFit
End If
Next i
Range("C1:C" & lr).ClearContents
Range("E1:F" & lr).ClearContents
End Sub

 

[muhmath2002]

mr maabadi
big thanks for working vba code
please modify last vba code to remove class name in cell c1 and let put extract student names from a1
god bless you

​

 

[maabadi]

1. First Delete Class Sheets Created ( Select first sheet, go to Last sheet hold Shift & Select it) & Delete them.
Don't Forget Formula:
Excel Formula:

=IFNA(VLOOKUP(B2,$E$2:$F$60,2,FALSE),"")

Sub ExtractStudents()
Dim d As Object, c As Variant, i As Long, lr As Long, ws As Worksheet, lr2 As Long, WS2 As Worksheet
Dim a As Long, j As Long, e As Long
Set ws = Sheets("data")
Set d = CreateObject("Scripting.Dictionary")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort , key1:=Range("B2:B" & lr), order1:=xlAscending, key2:=Range("A2:A" & lr), order2:=xlAscending, Header:=xlNo
c = Range("B2:B" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
Next i
ws.Range("E1").Value = "Unique"
ws.Range("E2").Resize(d.Count) = Application.Transpose(d.keys)
lr2 = ws.Cells(Rows.Count, 5).End(xlUp).Row
Range("E2:E" & lr2).Sort , key1:=Range("E2:E" & lr2), order1:=xlAscending, Header:=xlNo
For i = 2 To lr2
ws.Range("F" & i) = i - 1
Next i
For i = 2 To lr2
If ws.Cells(i, 5).Value <> "" Then
   a = Application.WorksheetFunction.CountIf(ws.Range("D2:D" & lr), ws.Cells(i, 6))
    For j = 2 To lr
    If ws.Cells(j, 2).Value <> "" Then
   ws.Cells(j, 3).Value = Application.WorksheetFunction.CountIf(ws.Range("D2:D" & j), ws.Range("F" & i))
    End If
    Next j
     Sheets.Add(After:=Sheets(Sheets.Count)).Name = ws.Cells(i, 5).Value
     For j = 1 To a 
     Range("A" & j).Value = Application.WorksheetFunction.Index(ws.Range("A2:A" & lr), Application.WorksheetFunction.Match(j , ws.Range("C2:C" & lr), 0), 1)
     Next j
     Range("A1:A" & a ).Sort , key1:=Range("A1:A" & a ), order1:=xlAscending, Header:=xlNo
     Columns("A").AutoFit
End If
Next i
Range("C1:C" & lr).ClearContents
Range("E1:F" & lr).ClearContents
End Sub

 

[muhmath2002]

Thank you very much for solving the file problem in my school

 

[maabadi]

You're Welcome & Thanks for Feedback.