lionheart

Maybe there's an extra space at the end of the worksheet code name wsList

Sub Committees_Absence() Rem Worksheets Dim wsData As Worksheet, wsCommittee As Worksheet Set wsData = ThisWorkbook.Worksheets(1) Set wsCommittee = ThisWorkbook.Worksheets(2) Rem Determine Subject Column Dim xSubject, iColSubject As Long xSubject = Application.Match(wsCommittee.Range("D8").Value, wsData.Range("F6:M6"), 0) If Not IsError(xSubject) Then iColSubject = xSubject + 5 Else MsgBox "No Such A Subject", vbExclamation: Exit Sub End If Rem Last Row In Data Worksheet Dim lrData As Long lrData = wsData.Cells(Rows.Count, "B").End(xlUp).Row Rem Absence Results In An Array Dim r As Long, n As Long ReDim aresults(1 To 1000, 1 To 4) For r = 7 To lrData If wsData.Cells(r, iColSubject).Value = Chr(219) Then n = n + 1 aresults(n, 1) = wsData.Cells(r, 5).Value 'Committee aresults(n, 2) = wsData.Cells(r, 3).Value 'Grade aresults(n, 3) = wsData.Cells(r, 2).Value 'Student Name aresults(n, 4) = wsData.Cells(r, 4).Value 'Seat Number End If Next r Rem Populate Results Dim iRow As Long With wsCommittee .Range("A11:F1000").ClearContents iRow = 11 If n > 0 Then .Range("A" & iRow).Resize(n, UBound(aresults, 2)).Value = aresults End With End Sub

The last point is not clear for me Sub Test() Const sSheetName As String = "Report" Dim e, ws As Worksheet, f As Boolean, t1 As Double, t2 As Double, x As Long, y As Long, r As Long, iRow As Long, fRow As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("MIN") On Error Resume Next Application.DisplayAlerts = False ThisWorkbook.Worksheets(sSheetName).Delete Application.DisplayAlerts = True On Error GoTo 0 Sheets.Add(After:=Sheets(Sheets.Count)).Name = sSheetName With ThisWorkbook.Worksheets(sSheetName) .DisplayRightToLeft = True .Cells.Clear With .Cells .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With iRow = 1 For y = 2012 To Year(Date) fRow = iRow t1 = 0: t2 = 0: x = 0 ws.Range("C14").Value = y With .Cells(iRow, 1) .Value = y .Font.Bold = True .Interior.Color = RGB(219, 219, 219) End With For Each e In Array("16|30", "32|41", "43|52") x = x + 1 f = False For r = Val(Split(e, "|")(0)) To Val(Split(e, "|")(1)) If ws.Cells(r, "U").Value > 0 And ws.Cells(r, "U").Value <> Empty Then If f = False Then iRow = iRow + 1 If x = 2 Then iRow = iRow + 1 .Cells(iRow, 2).Value = ws.Range(IIf(x = 1, "D", "B") & Val(Split(e, "|")(0)) - 1).Value .Cells(iRow, 3).Resize(, 6).Value = ws.Range("P" & Val(Split(e, "|")(0)) - 1).Resize(, 6).Value .Cells(iRow, 2).Resize(, 7).Interior.Color = vbYellow f = True End If iRow = iRow + 1 .Cells(iRow, 2).Value = ws.Cells(r, IIf(x = 1, "D", "B")).Value .Cells(iRow, 3).Resize(, 6).Value = ws.Cells(r, "P").Resize(, 6).Value t1 = t1 + .Cells(iRow, "F").Value t2 = t2 + .Cells(iRow, "H").Value End If Next r iRow = iRow + 1 If x = 1 Then iRow = iRow - 1 Next e iRow = iRow + 1 .Cells(iRow, 2).Value = "Total" With .Cells(iRow, "F") .Value = t1 .Interior.Color = vbCyan End With With .Cells(iRow, "H") .Value = t2 .Interior.Color = vbCyan End With iRow = iRow + 2 With .Range(.Cells(fRow, 2), .Cells(iRow - 2, 8)) .Borders.Value = 1 .BorderAround Weight:=3 End With f = False Next y .Rows.RowHeight = 19 .Columns(1).ColumnWidth = 9 For Each e In Array(3, 5, 6, 8) .Columns(e).NumberFormat = "0.00" Next e .Columns(7).NumberFormat = "0%" .Columns("B:H").AutoFit End With Application.ScreenUpdating = True End Sub

The image is not clear for me You can upload a file and highlight the notes

Sub Test() Const sSheetName As String = "Report" Dim e, ws As Worksheet, f As Boolean, t1 As Double, t2 As Double, x As Long, y As Long, r As Long, iRow As Long, fRow As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("MIN") On Error Resume Next Application.DisplayAlerts = False ThisWorkbook.Worksheets(sSheetName).Delete Application.DisplayAlerts = True On Error GoTo 0 Sheets.Add(After:=Sheets(Sheets.Count)).Name = sSheetName With ThisWorkbook.Worksheets(sSheetName) .DisplayRightToLeft = True .Cells.Clear With .Cells .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With iRow = 1 For y = 2012 To Year(Date) fRow = iRow t1 = 0: t2 = 0: x = 0 ws.Range("C14").Value = y With .Cells(iRow, 1) .Value = y .Font.Bold = True .Interior.Color = RGB(219, 219, 219) End With For Each e In Array("16|30", "32|41", "43|52") x = x + 1 f = False For r = Val(Split(e, "|")(0)) To Val(Split(e, "|")(1)) If ws.Cells(r, "U").Value > 0 And ws.Cells(r, "U").Value <> Empty Then If f = False Then iRow = iRow + 1 If x = 2 Then iRow = iRow + 1 .Cells(iRow, 2).Value = ws.Range(IIf(x = 1, "D", "B") & Val(Split(e, "|")(0)) - 1).Value .Cells(iRow, 3).Resize(, 6).Value = ws.Range("P" & Val(Split(e, "|")(0)) - 1).Resize(, 6).Value .Cells(iRow, 2).Resize(, 7).Interior.Color = vbYellow f = True End If iRow = iRow + 1 .Cells(iRow, 2).Value = ws.Cells(r, IIf(x = 1, "D", "B")).Value .Cells(iRow, 3).Resize(, 6).Value = ws.Cells(r, "P").Resize(, 6).Value t1 = t1 + .Cells(iRow, "F").Value t2 = t2 + .Cells(iRow, "H").Value End If Next r iRow = iRow + 1 If x = 1 Then iRow = iRow - 1 Next e iRow = iRow + 1 .Cells(iRow, 2).Value = "Total" With .Cells(iRow, "F") .Value = t1 .Interior.Color = vbCyan End With With .Cells(iRow, "H") .Value = t2 .Interior.Color = vbCyan End With iRow = iRow + 2 With .Range(.Cells(fRow, 2), .Cells(iRow - 2, 8)) .Borders.Value = 1 .BorderAround Weight:=3 End With f = False Next y .Rows.RowHeight = 19 .Columns(1).ColumnWidth = 9 .Columns("B:H").AutoFit End With Application.ScreenUpdating = True End Sub

You are right The data is not valid for manipulation in that structure How did you get such scrambled data

Have a look. Is that the desired output

To implement With your workbook active press Alt+F11 to bring up the vba window In the Visual Basic window use the menu to Insert|Module Copy and Paste the code below into the main right hand pane that opens at step 2 Close the Visual Basic window Press Alt+F8 to bring up the Macro dialog Select the macro & click 'Run' Your workbook will need to be saved as a macro-enabled workbook (*.xlsm)

In standard module, put the following UDF Function VLookUps(myCode As Range, myList As Range, delim As String, Optional Uniq As Boolean = False) As String Dim e VLookUps = Join(Filter(myList.Parent.Evaluate("TRANSPOSE(IF(" & myList.Columns(7).Address & "=" & myCode.Address(, , , True) & ", " & myList.Columns(2).Address & "))"), False, 0), delim) If Uniq Then With CreateObject("Scripting.Dictionary") .CompareMode = 1 For Each e In Split(VLookUps, delim) .Item(Trim(Split(e)(1))) = Empty Next e VLookUps = Join(.Keys, delim) End With End If End Function In cell F2, you can use the UDF as following =VLookUps(Tabla2[@[إسم ولي الأمر]],Tabla1[#All]," - ",TRUE)

Sub Test() Dim a, c As Long, r As Long With ActiveSheet r = 7 a = .Range("B7").CurrentRegion.Offset(1).Value For c = LBound(a, 2) To UBound(a, 2) .Range("E" & r).Resize(UBound(a, 1)).Value = Application.Index(a, , c) r = r + UBound(a, 1) - 1 Next c End With End Sub

Private Sub CommandButton2_Click() Dim i As Long, ii As Long, lr As Long, c As Long lr = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row + 1 c = 2 For i = 1 To Me.ListBox1.ListCount - 1 For ii = 0 To 4 Sheet1.Cells(lr, c + ii).Value = Me.ListBox1.List(i, ii) Next ii c = c + 5 Next i End Sub

Private Sub CommandButton1_Click() ActiveCell.Value = dpFrom.Value(1) ActiveCell.Offset(1).Value = dpFrom.Value(2) End Sub

Not clear Explain well what is the problem now

Sub Test() Const iNum As Double = 50 Dim a, t As Double, i As Long, k As Long Application.ScreenUpdating = False With ActiveSheet a = .Range("A4:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim b(1 To UBound(a, 1) * 10, 1 To 1) For i = LBound(a) To UBound(a) k = k + 1 If a(i, 1) <= iNum Then b(k, 1) = a(i, 1) ElseIf a(i, 1) > iNum Then t = a(i, 1) Do b(k, 1) = IIf(t >= iNum, iNum, t) t = t - iNum k = k + 1 If t <= iNum Then b(k, 1) = t: Exit Do Loop Until t < iNum End If Next i .Range("E10").Resize(k, UBound(b, 2)).Value = b End With Application.ScreenUpdating = True End Sub

The code sheet name is not the same

In standard module Dim timerActive As Boolean Public Sub Start_Timer() timerActive = True Application.OnTime Now() + TimeValue("00:00:01"), "Timer" End Sub Public Sub Stop_Timer() timerActive = False End Sub Public Sub Timer() If timerActive Then UserForm1.Label1.Caption = Time Application.OnTime Now() + TimeValue("00:00:01"), "Timer" End If End Sub then in userform module Private Sub UserForm_Activate() Call Start_Timer End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Call Stop_Timer End Sub

You can change the date in the code Sub Test() Const sReport As String = "Report" Dim ws As Worksheet, myDate As Date, lr As Long, r As Long, c As Long, k As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) lr = ws.Cells(Rows.Count, "C").End(xlUp).Row myDate = CLng(DateSerial(2017, 1, 1)) ReDim a(1 To (lr - 2) * 7, 1 To 6) For r = 3 To lr For c = 9 To 27 Step 3 If ws.Cells(r, c + 1).Value2 >= myDate Then k = k + 1 a(k, 1) = ws.Cells(r, 3).Value a(k, 2) = ws.Cells(r, 6).Value a(k, 3) = ws.Cells(r, 7).Value a(k, 4) = ws.Cells(r, c).Value a(k, 5) = ws.Cells(r, c + 1).Value a(k, 6) = ws.Cells(r, c + 2).Value End If Next c Next r If k > 0 Then On Error Resume Next Application.DisplayAlerts = False Worksheets(sReport).Delete Application.DisplayAlerts = True On Error GoTo 0 Sheets.Add(After:=Sheets(Sheets.Count)).Name = sReport With Worksheets(sReport) .DisplayRightToLeft = True .Range("A1").Resize(, 6).Value = Array("Father Name", "Mother Name", "Place", "Child", "Birth Date", "ID") .Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a .Columns.AutoFit End With End If Application.ScreenUpdating = True MsgBox "Done...", 64, "LionHeart" End Sub

Sub Test() Dim a, w, ws As Worksheet, f As Boolean, i As Long, ii As Long, k As Long, m As Long Application.ScreenUpdating = False Set ws = ActiveSheet ws.Range("B20").CurrentRegion.Offset(2).ClearContents w = ws.Range("D20").Value If w = Empty Then MsgBox "Enter ID First", vbExclamation: Exit Sub a = ws.Range("A3:P" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim b(1 To UBound(a, 1) * 4, 1 To 5) For i = LBound(a) To UBound(a) If a(i, 4) = w Then k = k + 1 b(k, 1) = a(i, 1) b(k, 2) = a(i, 2) m = 0 For ii = 5 To 14 Step 3 If a(i, ii) <> Empty Then f = True b(k + m, 3) = a(i, ii) b(k + m, 4) = a(i, ii + 1) b(k + m, 5) = a(i, ii + 2) m = m + 1 End If Next ii If m > 0 Then k = k + m - 1 If f = False Then b(k, 1) = Empty: b(k, 2) = Empty: f = False: k = k - 1 End If Next i If k > 0 Then ws.Range("B22").Resize(k, UBound(b, 2)).Value = b Application.ScreenUpdating = True End Sub

Delete columns from column A to column G Select column A From Data tab select Text to Columns Select Delimited option and click Next button Check Space option and click Next button In Destination field select $B$1 cell And finally click Finish

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

I think you have to show us your tries to solve the problem. Don't wait for others to dl all your work for you

The code is som simple and self-exaplanatory First stored the hidden columns in a variable then dislay the hidden columns then copy the visible rows only to an unused range and store the new range into the array and finally hide the hidden columns again

What happened after changing the variables and what changes did you do exactly And what about the results of the code

Are you joking Did you have a look at the code? Please have a look carefully and change the reference of the target cell