lionheart

Change the worksheet code names in VBE window to wsList and wsMonthlyAbsence
Sub Test() Dim x, v, f As Boolean, sTemp As String, lr As Long, c As Long, tot As Long, r As Long, m As Long, i As Long, ii As Long, col As Long Application.ScreenUpdating = False With wsList lr = .Cells(Rows.Count, "D").End(xlUp).Row wsMonthlyAbsence.Range("C6:J100").Value = Empty For c = 5 To 36 tot = Application.WorksheetFunction.CountA(.Range(.Cells(8, c), .Cells(lr, c))) If tot = 0 Then GoTo NXT f = True: m = 0: col = 0: sTemp = vbNullString For r = 8 To lr If .Cells(r, c).Value <> "" Then x = Application.Match(.Cells(7, c).Value2, wsMonthlyAbsence.Columns(2), 0) If Not IsError(x) Then If f Then wsMonthlyAbsence.Cells(x, "C").Value = tot wsMonthlyAbsence.Cells(x, "D").Value = lr - 8 + 1 - tot f = False End If sTemp = sTemp & IIf(sTemp = Empty, Empty, ",") & .Cells(r, 4).Value End If End If Next r If sTemp <> Empty Then v = Split(sTemp, ",") For i = LBound(v) To UBound(v) Step 3 For ii = 0 To 2 m = m + 1 If m > UBound(v) + 1 Then Exit For wsMonthlyAbsence.Cells(x + ii, col + 5).Value = v(i + ii) Next ii col = col + 1 Next i End If NXT: Next c End With Application.ScreenUpdating = True MsgBox "Done...", 64, "LionHeart" End Sub  

Sub Test() Application.ScreenUpdating = False With Sheet2 .[A1].CurrentRegion.Columns("B:D").AdvancedFilter xlFilterCopy, , .[H1], True End With With Sheet1 With .Range("E2:F" & .Cells(Rows.Count, "D").End(xlUp).Row) .Formula = "=INDEX(BASE!I$1:I$272,MATCH($D2,BASE!$H$1:$H$272,0))" .Value = .Value End With End With Sheet2.[H1].CurrentRegion.Clear Application.ScreenUpdating = True End Sub  

Sub Test() Dim a, e, c As Range, sCols As String, m As Long Application.ScreenUpdating = False With ActiveSheet m = .Cells(Rows.Count, 1).End(xlUp).Row + 10 With .Range("A1").CurrentRegion For Each c In .Rows(1).Cells If c.EntireColumn.Hidden Then sCols = sCols & IIf(sCols = "", "", "|") & c.Column Next c .EntireColumn.Hidden = False .Offset(1).SpecialCells(xlCellTypeVisible).Copy .Parent.Range("A" & m) End With With .Range("A" & m).CurrentRegion a = .Value: .Clear End With For Each e In Split(sCols, "|") .Columns(Val(e)).Hidden = True Next e End With Application.ScreenUpdating = True End Sub  

Sub Test() Dim rng As Range Application.ScreenUpdating = False With ActiveSheet Set rng = .Range("H2:L" & .Cells(Rows.Count, "H").End(xlUp).Row) With rng With .Columns(.Columns.Count) .Formula = "=MATCH(H2,B:B,0)" .Value = .Value rng.Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes .ClearContents End With End With End With Application.ScreenUpdating = True End Sub  

Sub Test() Dim ws As Worksheet, sh As Worksheet, rRange As Range, rCell As Range, rng As Range, t As Double, iRow As Long, r As Long, c As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(2) 'Tasks Set sh = ThisWorkbook.Worksheets(1) 'Summary iRow = 4: r = iRow With sh.Rows(iRow + 1 & ":" & Rows.Count) .ClearContents: .Borders.Value = 0 End With Set rRange = ws.Range("B5:B" & ws.Cells(Rows.Count, "B").End(xlUp).Row) Set rCell = rRange.Cells(1, 1) Do If rCell.Value = Chr(199) & Chr(225) & Chr(199) & Chr(204) & Chr(227) & Chr(199) & Chr(225) & Chr(237) Or rCell.Value = Empty Then GoTo NXT r = r + 1: t = 0 sh.Cells(r, 1).Value = r - iRow sh.Cells(r, 2).Value = rCell.Value For c = 3 To 16 Set rng = rCell.Offset(, c - 2).Resize(rCell.MergeArea.Rows.Count) t = Application.WorksheetFunction.Sum(rng) If t = 0 Then sh.Cells(r, c).Value = Empty Else sh.Cells(r, c).Value = t Next c NXT: Set rCell = rCell.Offset(1, 0) Set rng = Nothing Loop Until (rCell.Row > (rRange.Row + rRange.Rows.Count - 1)) With sh.Rows(iRow + 1 & ":" & r) .Borders.Value = 1 End With Application.ScreenUpdating = True End Sub  

Sub Test() Dim a, x, e, v, wsData As Worksheet, wsExisting As Worksheet, wsA As Worksheet, wsF As Worksheet, wsM As Worksheet, sh As Worksheet, i As Long, ii As Long, k1 As Long, k2 As Long, k3 As Long, n As Long Application.ScreenUpdating = False Set wsData = ThisWorkbook.Worksheets("Data") Set wsExisting = ThisWorkbook.Worksheets("Feuil1") Set wsA = ThisWorkbook.Worksheets("ARABE") Set wsF = ThisWorkbook.Worksheets("FRANCAIS") Set wsM = ThisWorkbook.Worksheets("MIXTE") a = wsData.Range("A2:H" & wsData.Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim b1(1 To UBound(a, 1), 1 To UBound(a, 2) - 1) ReDim b2(1 To UBound(a, 1), 1 To UBound(a, 2) - 1) ReDim b3(1 To UBound(a, 1), 1 To UBound(a, 2) - 1) For i = LBound(a, 1) To UBound(a, 1) x = Application.Match(a(i, 1), wsExisting.Columns(1), 0) If Not IsError(x) Then GoTo NXT If a(i, 8) = "ARABE" Then k1 = k1 + 1 For ii = 1 To 7 b1(k1, ii) = a(i, ii) Next ii ElseIf a(i, 8) = "FRANCAIS" Then k2 = k2 + 1 For ii = 1 To 7 b2(k2, ii) = a(i, ii) Next ii ElseIf a(i, 8) = "MIXTE" Then k3 = k3 + 1 For ii = 1 To 7 b3(k3, ii) = a(i, ii) Next ii End If NXT: Next i For Each e In Array(1, 2, 3) If e = 1 Then Set sh = wsA: n = k1: v = b1 ElseIf e = 2 Then Set sh = wsF: n = k2: v = b2 ElseIf e = 3 Then Set sh = wsM: n = k3: v = b3 End If If n > 0 Then sh.Range("A1").CurrentRegion.ClearContents sh.Range("A1").Resize(, 7).Value = wsData.Range("A1").Resize(, 7).Value sh.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v End If Next e Application.ScreenUpdating = True End Sub  

Sub Test() GenerateUniqueRandom ActiveSheet, "D3:F22", 1, 60 End Sub Sub GenerateUniqueRandom(ByVal shTarget As Worksheet, ByVal sRng As String, ByVal iStart As Long, iEnd As Long) Dim w, v, rng As Range, c As Range, n As Long, i As Long, ii As Long, r As Long Set rng = shTarget.Range(sRng) If iEnd - iStart + 1 > rng.Cells.Count Then MsgBox "Generated Numbers Greater Than Range Cell Count", vbExclamation: Exit Sub w = Evaluate("ROW(" & iStart & ":" & iEnd & ")") n = 0 ReDim v(1 To rng.Rows.Count, 1 To rng.Columns.Count) For i = LBound(v, 1) To UBound(v, 1) For ii = LBound(v, 2) To UBound(v, 2) r = Application.RandBetween(iStart, UBound(w) - n) v(i, ii) = w(r, 1) w(r, 1) = w(UBound(w) - n, 1) n = n + 1 Next ii Next i rng.Cells(1).Resize(UBound(v, 1), UBound(v, 2)).Value = v End Sub  

Sub Test() Dim m As Long m = Cells(Rows.Count, 1).End(xlUp).Row + 1 Rows(m & ":" & Rows.Count).Clear End Sub  

Sub Test() Dim rng As Range, c As Long Application.ScreenUpdating = False Set rng = Range("A5:J" & Cells(Rows.Count, "D").End(xlUp).Row) rng.UnMerge For c = 1 To rng.Columns.Count With rng.Columns(c) On Error Resume Next .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C" If c = 3 Then .Text = .Text Else .Value = .Value On Error GoTo 0 End With Next c Application.ScreenUpdating = True End Sub  

In any worksheet module, put the following code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Const sListBoxName As String = "Export Sheets" Dim ws As Worksheet, lst As ListBox, sPath As String, sFile As String, i As Long, c As Long If Target.Address = "$A$1" Then Cancel = True With Me Set lst = Nothing On Error Resume Next Set lst = .ListBoxes(sListBoxName) On Error GoTo 0 If lst Is Nothing Then Set lst = .ListBoxes.Add(.Range("F2").Left, .Range("F2").Top, 160, 84) End With With lst .Name = sListBoxName .RemoveAllItems .MultiSelect = xlSimple For Each ws In ActiveWorkbook.Sheets .AddItem ws.Name Next ws End With ElseIf Target.Address = "$B$1" Then Cancel = True Set lst = Me.ListBoxes(sListBoxName) With lst For i = 1 To .ListCount If .Selected(i) Then c = c + 1 sPath = ThisWorkbook.Path & "\" With ActiveWorkbook.Sheets(.List(i)) Application.ScreenUpdating = False Application.DisplayAlerts = False .Copy: sFile = .Name With Application.ActiveWorkbook .SaveAs Filename:=sPath & sFile & ".xlsx" .Close False End With Application.DisplayAlerts = True Application.ScreenUpdating = True End With End If Next i End With If c > 0 Then MsgBox "You Exported " & c & " Sheets Successfully", 64, "LionHeart" End If End Sub  
To use the code
Double-click cell A1 and a listbox with the worksheets names will be created
Select the sheet or sheets you want to export from the listbox
 Finally double-click cell B1 to export the sheets you selected from the listbox

Sub Test_Timer() Dim i As Long, k As Long Range("B3").Value = 0 Do Until Range("B3").Value = 4 Range("B3").Value = Range("B3").Value + 1 For i = 5 To 1 Step -1 Application.ScreenUpdating = True Range("E3").Value = i DoEvents For k = 1 To 100000000 Next k Next i Application.Wait Now + TimeValue("00:00:01") Loop End Sub  

Sub Test_Timer() Dim i As Long, k As Long Range("B3").Value = 0 Do Until Range("B3").Value = 4 Range("B3").Value = Range("B3").Value + 1 For i = 5 To 1 Step -1 Application.ScreenUpdating = True Range("E3").Value = i DoEvents For k = 1 To 100000000 Next k Next i Application.Wait Now + TimeValue("00:00:01") Loop End Sub  

Sub Test() Dim a, vArray(), sOut As String, i As Long, ii As Long, k As Long Application.ScreenUpdating = False a = Range("A2").CurrentRegion.Value ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 1) For i = LBound(a, 1) To UBound(a, 1) For ii = LBound(a, 2) To UBound(a, 2) k = k + 1 b(k, 1) = a(i, ii) Next ii Next i Columns("G").ClearContents Range("G2").Resize(UBound(b, 1), UBound(b, 2)).Value = b vArray = Application.Transpose(b) sOut = Join(vArray, vbCrLf) Open ThisWorkbook.Path & "\Output.txt" For Output As #1 Print #1, sOut Close #1 Application.ScreenUpdating = True MsgBox "Done...", 64, "LionHeart" End Sub  

That's great you have tried that's a great step towards learning
Sub Test() Dim m As Long, r As Long, n As Long Application.ScreenUpdating = False With ActiveSheet m = .Cells(Rows.Count, 1).End(xlUp).Row n = 1 .Columns("K:M").WrapText = True For r = 1 To m Step 3 .Range("K" & n).Resize(, 3).Value = Array(.Range("A" & r).Value & vbLf & .Range("A" & r + 1).Value & vbLf & .Range("A" & r + 2).Value, .Range("B" & r).Value & vbLf & .Range("B" & r + 1).Value & vbLf & .Range("B" & r + 2).Value, .Range("C" & r).Value & vbLf & .Range("C" & r + 1).Value & vbLf & .Range("C" & r + 2).Value) n = n + 1 Next r End With Application.ScreenUpdating = True End Sub  

=IF(D18=11,(IO9),IF(D18=11.3,(IP9),IF(D18=11.7,(IQ9),IF(D18=12,(IR9),IF(D18=12.3,(IS9),IF(D18=12.7,(IT9),IF(D18=13,(IV9)," ")))))))  
PT.xlsx

Sub Test() Dim a, r As Long, i As Long Application.ScreenUpdating = False r = 2 For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row Step 3 a = Range("A" & i).Resize(3).Value Cells(r, "C").Resize(, UBound(a)).Value = Application.Transpose(a) r = r + 1 Next i Application.ScreenUpdating = True End Sub  

Sub Test() Dim a, ws As Worksheet, rng As Range, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) m = ws.Cells(Rows.Count, "B").End(xlUp).Row Set rng = ws.Range("B3:B" & m) rng.Offset(, 1).Formula = "=kh_Names($B3,1,2)" rng.Offset(, 2).Formula = "=kh_Names($B3,1,2,3)" rng.Offset(, 3).Formula = "=kh_Names($B3,1,2,3,4)" rng.Offset(, 4).Formula = "=IF(COUNTIF($C$3:$C$" & m & ",C3)>1,COUNTIF($C$3:$C$" & m & ",C3),C3)" rng.Offset(, 5).Formula = "=IFERROR(IF(VALUE(F3)>1,IF(COUNTIF($D$3:$D$" & m & ",D3)>1,COUNTIF($D$3:$D$" & m & ",D3),D3),""""),"""")" rng.Offset(, 6).Formula = "=IFERROR(IF(VALUE(G3)>1,IF(COUNTIF($E$3:$E$" & m & ",E3)>1,COUNTIF($E$3:$E$" & m & ",E3),E3),""""),"""")" With rng.Offset(, 7) .Formula = "=CONCATENATE(IF(AND(ISTEXT(F3),F3<>""""),F3,""""),IF(AND(ISTEXT(G3),G3<>""""),G3,""""),IF(AND(ISTEXT(H3),H3<>""""),H3,""""))" a = .Value rng.Offset(, 1).Value = a End With ws.Columns("D:I").ClearContents Application.ScreenUpdating = True End Sub  

Sub Test() Dim r As Long Application.ScreenUpdating = 0 For r = 5 To Cells(Rows.Count, "C").End(xlUp).Row If Cells(r, "C").Value <> "" Then If Cells(r, "F").Value <> "" And Cells(r, "G").Value = "" Then Cells(r, "G").Value = 0 End If If Cells(r, "F").Value = "" And Cells(r, "G").Value <> "" Then Cells(r, "F").Value = 0 End If End If Next r Application.ScreenUpdating = 1 End Sub  

Close Excel application
Download MSSTKPRP.zip file and extract the MSSTKPRP.DLL to these paths
C:\Windows\System32 C:\Windows\SysWOW64 Open command prompt as administrator and type these commands
cd C:\Windows\System32 regsvr32 MSSTKPRP.DLL cd C:\Windows\SysWOW64 regsvr32 MSSTKPRP.DLL You may need to restart your pc

Option Explicit Const iCol As Integer = 7 Sub Test() Dim e, rng As Range, lr As Long Const sOutput As String = "Output" Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next: Sheets(sOutput).Delete: On Error GoTo 0 Application.DisplayAlerts = True Sheets(1).Copy , Sheets(Sheets.Count) Sheets(Sheets.Count).Name = sOutput With Sheets(sOutput) lr = .Cells(Rows.Count, 1).End(xlUp).Row .Range("A1").CurrentRegion.Borders.Value = 1 .Columns("A:F").AutoFit With .Columns("G") .ColumnWidth = 80 .Rows("1:" & lr).HorizontalAlignment = xlRight End With .Range("A1").Resize(, iCol).Interior.Color = RGB(255, 217, 102) With .Sort .SortFields.Clear For Each e In Array("A1", "B1", "C1", "D1", "E1") .SortFields.Add Key:=Range(e), Order:=xlAscending Next e .SetRange Range("A1:A" & lr).Resize(, iCol) .Header = xlYes .Apply End With Set rng = .Range("A2:A" & lr) MergeSimilarCells rng End With Application.ScreenUpdating = True End Sub Sub MergeSimilarCells(workRng As Range) Dim rng As Range, nRng As Range, xRows As Integer, i As Integer, j As Integer, ii As Integer, cnt As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False xRows = workRng.Rows.Count For Each rng In workRng.Columns For i = 1 To xRows - 1 For j = i + 1 To xRows If rng.Cells(i, 1).Value <> rng.Cells(j, 1).Value Then Exit For Next j Set nRng = workRng.Parent.Range(rng.Cells(i, 1), rng.Cells(j - 1, 1)) If nRng.Rows.Count > 1 Then For ii = 0 To 4 nRng.Offset(, ii).Resize(nRng.Rows.Count).Merge Next ii End If nRng.Resize(, iCol).BorderAround Weight:=xlThick nRng.Offset(, iCol - 1).Resize(nRng.Rows.Count).WrapText = True cnt = cnt + 1 If cnt Mod 2 = 0 Then nRng.Resize(, iCol).Interior.Color = RGB(255, 230, 152) Else nRng.Resize(, iCol).Interior.Color = RGB(255, 242, 204) End If i = j - 1 Next i Next rng Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub  

The name in cell C10 should have a space between the first name and last name so as to be identical as the name in cell C5
Sub Test() Dim a, txt As String, i As Long, ii As Long a = Range("C5:G" & Cells(Rows.Count, "C").End(xlUp).Row).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) txt = a(i, 1) If Not .Exists(txt) Then .Item(txt) = .Count + 1 For ii = 1 To UBound(a, 2) a(.Count, ii) = a(i, ii) Next ii Else For ii = 2 To UBound(a, 2) a(.Item(txt), ii) = a(.Item(txt), ii) + a(i, ii) Next ii End If Next i i = .Count End With [J6].Resize(i, UBound(a, 2)) = a End Sub  

Private Sub Worksheet_Activate() Dim e, ws As Worksheet For Each ws In ThisWorkbook.Worksheets If ws.Name <> Me.Name Then ws.Visible = xlSheetVeryHidden End If Next ws For Each e In Array("1", "2") Worksheets(e).Visible = xlSheetVisible Next e End Sub  

Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, lc As Long, r As Long, c As Long, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) sh.Range("B7:C100").ClearContents lr = LastRow(ws) lc = LastCol(ws) m = 7 For r = 4 To lr Step 2 For c = 1 To lc If ws.Cells(r + 1, c).Value <> "" Then sh.Cells(m, 2).Value = ws.Cells(r, c).Value sh.Cells(m, 3).Value = ws.Cells(r + 1, c).Value m = m + 1 End If Next c Next r Application.ScreenUpdating = True MsgBox "Done", 64 End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row On Error GoTo 0 End Function Function LastCol(sh As Worksheet) On Error Resume Next LastCol = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column On Error GoTo 0 End Function  

Here's a file with 3000 rows
File.xlsm

You can use helper columns A & B to achieve what you need by formulas
مباريات.xlsx