Macro to create new sheets from column with data delimited with semicolon

I

Itx77

New Member
Joined
Apr 6, 2022
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Dear experts,

Hope you are all safe and sound,

I´m trying to create a report to identify students from attendance week. The data comes as the image below (semicolon separated with the week names):

1649253477508.png

For column Weeks I would like to create a new sheet for each week and list the students that will attend that week.

Sheet Week 1: Maria, Sally
Sheet Week 2: Maria, Albert, Sally
Sheet Week 3 Maria, Sara
Sheet Week 4: Albert

Would like to do it with VBA as trying to get teachers life easier with a macro.

Thank you very much in advance,
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Sort by date Sort by votes
Dear *Itx77,
It can be a better solution, but VBA codes below will do what you asked for :unsure:
Before running the macro "LetsGO", please assign the name "Main" to your sheet containing Data (see image attached)
VBA Code: 
Sub LetsGO()
    Sheets("Main").Select
    Application.ScreenUpdating = False
    Columns("D:Z").ClearContents
    Range(Range("A2"), Range("A65000").End(xlUp)).Name = "NamesRng_0"
    Range(Range("B2"), Range("B65000").End(xlUp)).Name = "WeeksRng"
    Dim WksCll As Range
    For Each WksCll In Range("WeeksRng")
       Dim Data() As String
        Data = Split(WksCll, " ")
        Range("D65000").End(xlUp).Offset(1).Resize(UBound(Data) + 1) = Application.Transpose(Data)
    Next
    Columns("G:G").Replace What:=";", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    Columns("D:D").Replace What:=";", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Call Sort_Remove_Duplicates
    Call Create_Sheets
    Call Prepare_4Distribute_Names_2Sheets
    Call Distribute_Names_2Sheets
End Sub

Sub Sort_Remove_Duplicates()
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("D1"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveSheet.Sort
        .SetRange Range("D:D")
        .Apply
    End With
    Columns("D:D").RemoveDuplicates Columns:=1, Header:=xlNo
    Range(Range("D1"), Range("D65000").End(xlUp)).Name = "SheetsRng"
End Sub

Sub Create_Sheets()
    Dim ShtCll As Range
    For Each ShtCll In Range("SheetsRng")
            Dim ws As Worksheet
            Dim check As Boolean
            For Each ws In Worksheets
                If ws.Name Like ShtCll Then check = True: Exit For
            Next
            If check = True Then
            Else
            Sheets.Add(After:=Sheets(1)).Name = ShtCll
            End If
    Next
    Sheets("Main").Select
    Range("D:D") = ""
End Sub

Sub Prepare_4Distribute_Names_2Sheets()
    Sheets("Main").Select
    Columns("D:Z").ClearContents
    Range("WeeksRng").TextToColumns Destination:=Range("E2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=True, Other:=False, FieldInfo:= _
        Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
        Range("NamesRng_0").Copy
        Range("D2").PasteSpecial (xlPasteValues)
        Application.CutCopyMode = False
        Range(Range("D2"), Range("D65000").End(xlUp)).Name = "NamesRng_1"
End Sub

Sub Distribute_Names_2Sheets()
    Dim NmCll As Range
    For Each NmCll In Range("NamesRng_1")
        Dim CntWeeks As Single
        CntWeeks = WorksheetFunction.CountA(Range(NmCll, NmCll.End(xlToRight))) - 1
        Dim i As Integer
        For i = 1 To CntWeeks
            Dim ShtNm As String
            ShtNm = NmCll.Offset(0, i).Value
            Sheets(ShtNm).Range("A65000").End(xlUp).Offset(1) = NmCll.Value
        Next i
     Next
     Columns("D:Z").ClearContents
     Range("A1").Select
     MsgBox "  All  Done    ", vbInformation, " Dear  *Itx77"
End Sub
 

Attachments

  • Capture.JPG
    Capture.JPG
    53.4 KB · Views: 9
Upvote 0
Dear Sahak,

Thanks a lot for your time on answering the issue we are facing and apologies for the late reply :)

We have tried your code and it throws an error, I think it is caused because the "weeks" data will come with this kind of format:

From 1st of july to 7th; From 8th of july to 15th

1650117402505.png


When we run the macro, the error says "Type Mismatch" and the debugger points to this line:

Range("D65000").End(xlUp).Offset(1).Resize(UBound(Data) + 1) = Application.Transpose(Data)

Do you know if it is because of the type of data?

Thanks a lot in advance!

Sahak said:
Dear *Itx77,
It can be a better solution, but VBA codes below will do what you asked for :unsure:
Before running the macro "LetsGO", please assign the name "Main" to your sheet containing Data (see image attached)
VBA Code: 
Sub LetsGO()
    Sheets("Main").Select
    Application.ScreenUpdating = False
    Columns("D:Z").ClearContents
    Range(Range("A2"), Range("A65000").End(xlUp)).Name = "NamesRng_0"
    Range(Range("B2"), Range("B65000").End(xlUp)).Name = "WeeksRng"
    Dim WksCll As Range
    For Each WksCll In Range("WeeksRng")
       Dim Data() As String
        Data = Split(WksCll, " ")
        Range("D65000").End(xlUp).Offset(1).Resize(UBound(Data) + 1) = Application.Transpose(Data)
    Next
    Columns("G:G").Replace What:=";", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    Columns("D:D").Replace What:=";", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Call Sort_Remove_Duplicates
    Call Create_Sheets
    Call Prepare_4Distribute_Names_2Sheets
    Call Distribute_Names_2Sheets
End Sub

Sub Sort_Remove_Duplicates()
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("D1"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveSheet.Sort
        .SetRange Range("D:D")
        .Apply
    End With
    Columns("D:D").RemoveDuplicates Columns:=1, Header:=xlNo
    Range(Range("D1"), Range("D65000").End(xlUp)).Name = "SheetsRng"
End Sub

Sub Create_Sheets()
    Dim ShtCll As Range
    For Each ShtCll In Range("SheetsRng")
            Dim ws As Worksheet
            Dim check As Boolean
            For Each ws In Worksheets
                If ws.Name Like ShtCll Then check = True: Exit For
            Next
            If check = True Then
            Else
            Sheets.Add(After:=Sheets(1)).Name = ShtCll
            End If
    Next
    Sheets("Main").Select
    Range("D:D") = ""
End Sub

Sub Prepare_4Distribute_Names_2Sheets()
    Sheets("Main").Select
    Columns("D:Z").ClearContents
    Range("WeeksRng").TextToColumns Destination:=Range("E2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=True, Other:=False, FieldInfo:= _
        Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
        Range("NamesRng_0").Copy
        Range("D2").PasteSpecial (xlPasteValues)
        Application.CutCopyMode = False
        Range(Range("D2"), Range("D65000").End(xlUp)).Name = "NamesRng_1"
End Sub

Sub Distribute_Names_2Sheets()
    Dim NmCll As Range
    For Each NmCll In Range("NamesRng_1")
        Dim CntWeeks As Single
        CntWeeks = WorksheetFunction.CountA(Range(NmCll, NmCll.End(xlToRight))) - 1
        Dim i As Integer
        For i = 1 To CntWeeks
            Dim ShtNm As String
            ShtNm = NmCll.Offset(0, i).Value
            Sheets(ShtNm).Range("A65000").End(xlUp).Offset(1) = NmCll.Value
        Next i
     Next
     Columns("D:Z").ClearContents
     Range("A1").Select
     MsgBox "  All  Done    ", vbInformation, " Dear  *Itx77"
End Sub
Click to expand...
 
Upvote 0
Dear *Itx77,
Yes, it gives an error because you have totally different data under "Weeks"
Now I need to know what names will have sheets from for example
From 28th of June 2 2nd of July;From 5th to 9th of july;From 12th to 16th of july
Click to expand...
 
Upvote 0
Sahak said:
Dear *Itx77,
Yes, it gives an error because you have totally different data under "Weeks"
Now I need to know what names will have sheets from for example
Click to expand...
Dear Sahak,

Thanks for your quick answer,

Unfortunatelly the data will be different each time, as it would be the dates for attending class. It will come with semi colon separated.

Does this make sense for you?

Thanks in advance!
 
Upvote 0
Dear *Itx77,
If we will separate using semicolon, then for "From 28th of June 2 2nd of July;From 5th to 9th of july;From 12th to 16th of july" we should give to sheets names:
  • From 28th of June 2 2nd of July
  • From 5th to 9th of july
  • From 12th to 16th of july
If yes, then what name will have the sheet for "From 27th of September to 1st of October", it will fit only "From 27th of September to 1st o", because the maximum length of the sheet name is 31 characters?
 
Upvote 0
May be:
VBA Code: 
Option Explicit
Sub test()
Dim lr&, i&, cell As Range, ws As Worksheet, s, key, dic As Object
Set dic = CreateObject("scripting.dictionary")
With Worksheets("Sheet1")
lr = .Cells(Rows.Count, "A").End(xlUp).Row
    For Each cell In .Range("B2:B" & lr)
        s = Split(cell, ";")
        For i = 0 To UBound(s)
            If Not dic.exists(Trim(s(i))) Then
                dic.Add Trim(s(i)), cell.Offset(0, -1).Value
            Else
                dic(Trim(s(i))) = dic(Trim(s(i))) & "|" & cell.Offset(0, -1).Value
            End If
        Next
    Next
    For Each key In dic.keys
        ThisWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
        s = Split(dic(key), "|")
        For i = 0 To UBound(s)
            With ActiveSheet
                .name = key
                .Range("A1:B1").Value = Array("Name", "Week")
                .Cells(i + 2, "A").Value = s(i)
            End With
        Next
    Next
End With
End Sub
 

Attachments

  • before.JPG
    before.JPG
    25.2 KB · Views: 10
  • after.JPG
    after.JPG
    22.9 KB · Views: 10
Upvote 0
Sahak said:
Dear *Itx77,
If we will separate using semicolon, then for "From 28th of June 2 2nd of July;From 5th to 9th of july;From 12th to 16th of july" we should give to sheets names:
  • From 28th of June 2 2nd of July
  • From 5th to 9th of july
  • From 12th to 16th of july
If yes, then what name will have the sheet for "From 27th of September to 1st of October", it will fit only "From 27th of September to 1st o", because the maximum length of the sheet name is 31 characters?
Click to expand...
Dear Sahak,

We can limit the characters of the Weeks data to do not exceed 30 characters. Best option would be to name the sheets as the Weeks names.

Hope it makes sense and thanks in advance,
 
Upvote 0
bebo021999 said:
May be:
VBA Code: 
Option Explicit
Sub test()
Dim lr&, i&, cell As Range, ws As Worksheet, s, key, dic As Object
Set dic = CreateObject("scripting.dictionary")
With Worksheets("Sheet1")
lr = .Cells(Rows.Count, "A").End(xlUp).Row
    For Each cell In .Range("B2:B" & lr)
        s = Split(cell, ";")
        For i = 0 To UBound(s)
            If Not dic.exists(Trim(s(i))) Then
                dic.Add Trim(s(i)), cell.Offset(0, -1).Value
            Else
                dic(Trim(s(i))) = dic(Trim(s(i))) & "|" & cell.Offset(0, -1).Value
            End If
        Next
    Next
    For Each key In dic.keys
        ThisWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
        s = Split(dic(key), "|")
        For i = 0 To UBound(s)
            With ActiveSheet
                .name = key
                .Range("A1:B1").Value = Array("Name", "Week")
                .Cells(i + 2, "A").Value = s(i)
            End With
        Next
    Next
End With
End Sub
Click to expand...
Dear Bebo021999,

Many thanks for your answer, it works by limiting the weeks names to 30 characters!

Thanks a lot for your time
 
Upvote 0
Dear *Itx77, glad to see you got what you needed. Thank you Bebo021999.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Can a macro help create a user hierarchy?
Replies
7
Views
257
Akuini
Akuini
S
  • Question
Creating new sheets from template sheet plugging data into new sheets with particular criterias
Replies
1
Views
106
mumps
mumps
A
  • Question
Dynamically add new rows via VBA when using IFERROR TEXTJOIN and FILTER formulas from Table?
Replies
0
Views
162
AlfredDB
A
M
  • Question
VBA to hide current sheet, then create new sheet from template
Replies
3
Views
200
Micron
M
J
  • Solved
Create new sheets copying and highlighting data from original
2
Replies
19
Views
674
joshlee
J

Forum statistics

Threads
1,215,734
Messages
6,126,543
Members
449,316
Latest member
sravya

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
Back
Top