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

#### muhmath2002

##### New Member
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
best regards

### Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

#### maabadi

##### Well-known Member
What about Empty Cells at Class Names?

#### maabadi

##### Well-known Member
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)
Excel Formula:
``=IFNA(VLOOKUP(B2,\$E\$2:\$F\$60,2,FALSE),"")``

2. try this:
VBA Code:
``````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

##### Well-known Member
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)
Excel Formula:
``=IFNA(VLOOKUP(B2,\$E\$2:\$F\$60,2,FALSE),"")``
Try this Modified Macro:
VBA Code:
``````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

##### New Member

ADVERTISEMENT

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

##### Well-known Member
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:
Excel Formula:
``=IFNA(VLOOKUP(B2,\$E\$2:\$F\$60,2,FALSE),"")``

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

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

#### maabadi

##### Well-known Member
You're Welcome & Thanks for Feedback.

Replies
6
Views
296
Replies
14
Views
611
Replies
8
Views
83
Replies
0
Views
56
Replies
13
Views
550

Threads
1,128,015
Messages
5,628,147
Members
416,295
Latest member
jjkh58

### Share this page ### 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