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