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

muhmath2002

New Member
Joined
Dec 16, 2019
Messages
23
Office Version
  1. 2007
Platform
  1. Windows
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
 

Some videos you may like

Excel Facts

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

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,673
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
What about Empty Cells at Class Names?
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,673
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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
Joined
Oct 22, 2012
Messages
1,673
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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
Joined
Dec 16, 2019
Messages
23
Office Version
  1. 2007
Platform
  1. Windows

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
Joined
Oct 22, 2012
Messages
1,673
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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
Joined
Dec 16, 2019
Messages
23
Office Version
  1. 2007
Platform
  1. Windows
Thank you very much for solving the file problem in my school
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,673
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
You're Welcome & Thanks for Feedback.
 

Watch MrExcel Video

Forum statistics

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

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
Top