lionheart

I think this is a different request. Please post a new topic for the new question

Does the code raises any errors? The code is working well on my side. Just select the suitable month as the date in cell D2 is in March and the selected month is February

In First worksheet in cell AH4 change the month to March then try the following code Sub Test() Dim x, ws As Worksheet, lr As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) With ws lr = .Cells(Rows.Count, "B").End(xlUp).Row + 1 x = Application.Match(.Range("D2").Value2, .Rows(6), 0) If Not IsError(x) Then .Cells(lr, 1).Value = .Cells(lr, 1).Row - 6 .Cells(lr, 2).Value = .Range("B2").Value .Cells(lr, x).Resize(, .Range("F2").Value).Value = .Range("C2").Value End If End With Application.ScreenUpdating = True End Sub

The results will be populated to the suitable number of columns so you can't modify the number of columns in results. Try to put more names and values and you will see the output will be populated in more than five columns

In worksheet module, try the code Private Sub Worksheet_Change(ByVal Target As Range) Dim x, sh As Worksheet, m As Long If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Row > 1 And Target.Column = 1 Then Set sh = ThisWorkbook.Worksheets(2) m = sh.Cells(31, 1).End(xlUp).Row + 1 If m >= 31 Or (m = 2 And sh.Range("A2").Value <> Empty) Then MsgBox "No More Fields", vbExclamation: Exit Sub x = Application.Match(Target.Offset(, 1).Value, sh.Columns(1), 0) If Not IsError(x) Then MsgBox "Customer Already Exists", vbExclamation: Exit Sub sh.Cells(m, 1).Value = Target.Offset(, 1).Value Target.Select End If End Sub

I have downloaded both of your files and both of them don't work when changing the dates The VBA codes have no problem. The problem is with the file itself

If you deal with macros, there is no UNDO. So you can't undo the action. If you type a wrong student number you have to close the file without saving the changes

Describe exactly what you did manually and attach the new file

No need to apply filter as the code will search the student number and copy the related row. Also there is a message box that shows you the number of row that is copied

Try this code Sub Test_LionHeart() Dim a, b, lr As Long With ActiveSheet lr = .Cells(Rows.Count, 1).End(xlUp).Row .Range("D2:H" & lr).ClearContents a = CreateNamesArray(.Range("A2:A" & lr), .Range("B2:B" & lr)) ShuffleArray a b = ConvertToColumns(a, lr - 1) .Range("D2").Resize(UBound(b, 1), UBound(b, 2)).Value = b End With End Sub Function CreateNamesArray(ByVal namesRange As Range, ByVal countRange As Range) Dim nameArray, nameIndex As Long, countIndex As Long, rowCount As Long, totalNames As Long, currCount As Long, i As Long rowCount = namesRange.Rows.Count totalNames = WorksheetFunction.Sum(countRange) ReDim nameArray(1 To totalNames, 1 To 1) nameIndex = 1 For countIndex = 1 To rowCount currCount = countRange(countIndex, 1).Value For i = 1 To currCount nameArray(nameIndex, 1) = namesRange(countIndex, 1).Value nameIndex = nameIndex + 1 Next i Next countIndex CreateNamesArray = nameArray End Function Private Sub ShuffleArray(ByRef arr) Dim temp, i As Long, j As Long Randomize For i = LBound(arr) To UBound(arr) j = Int((UBound(arr) - i + 1) * Rnd + i) temp = arr(i, 1) arr(i, 1) = arr(j, 1) arr(j, 1) = temp Next i End Sub Function ConvertToColumns(ByVal inputArray, ByVal divisor As Long) Dim numOutputCols As Long, i As Long, j As Long, k As Long numOutputCols = Application.WorksheetFunction.RoundUp(UBound(inputArray, 1) / divisor, 0) ReDim outputArray(1 To divisor, 1 To numOutputCols) k = 1 For j = 1 To numOutputCols For i = 1 To divisor If k <= UBound(inputArray, 1) Then outputArray(i, j) = inputArray(k, 1) k = k + 1 End If Next i Next j ConvertToColumns = outputArray End Function

In worksheet module put the code Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim rng As Range Set rng = Range("F9:L13") If Not Intersect(Target, rng) Is Nothing Then Cancel = True Call VBA_Circle_Text Range("K17").Value = CountOvalShapes(rng) End If End Sub Sub VBA_Circle_Text() Dim cel As Range, m As Double, n As Double Set cel = Application.Selection DeleteShapesWithinRange cel With cel m = .Height * 0.1 n = .Width * 0.1 Application.ActiveSheet.Ovals.Add Top:=.Top - m, Left:=.Left - n, Height:=.Height + 2.25 * m, Width:=.Width + 1.75 * n With Application.ActiveSheet.Ovals(ActiveSheet.Ovals.Count) .Interior.ColorIndex = xlNone With .ShapeRange.Line .Weight = 2 .ForeColor.RGB = vbRed End With End With End With cel.Select End Sub Function CountOvalShapes(ByVal rng As Range) As Long Dim shp As Shape, cnt As Long For Each shp In ActiveSheet.Shapes If shp.Type = 1 And Not Intersect(shp.TopLeftCell.MergeArea, rng) Is Nothing Then cnt = cnt + 1 Next shp CountOvalShapes = cnt End Function Sub DeleteShapesWithinRange(ByVal rng As Range) Dim shp As Shape For Each shp In rng.Parent.Shapes If Not Application.Intersect(rng.Parent.Range(shp.TopLeftCell.Offset(1, 1).Address), rng) Is Nothing Then shp.Delete Next shp End Sub

Thanks a lot my dear Hassona for sharing

Press Alt + F11 > Insert Module > Paste the UDF I am sure you didn't do these steps. This is user-defined function which is not implemented in excel functions

.Prepare your file with some of the expected results and please be accurate You didn't pay attention to my replies and didn't answer to my questions

You should write a number from column A in cell E2 The code is working fine on my side

I meant 65 rows * 5 columns (from column D to column H)

=SubtractDigits(A1) You can use it a formula in the worksheet If you need pure formula that works from the worksheet without UDF, so wait for others (I have no idea)

In worksheet module, paste the following code Private Sub Worksheet_Change(ByVal Target As Range) Dim x, m As Long If Target.Address = "$E$2" Then If Target.Value = Empty Then Exit Sub x = Application.Match(Val(Target.Value), Columns(1), 0) If Not IsError(x) Then With Sheets("Copied") m = .Cells(Rows.Count, 1).End(xlUp).Row + 1 Rows(x).Copy .Cells(m, 1) End With MsgBox "Row " & x & " Copied Successfully", 64 Else MsgBox "No Found", vbExclamation: Exit Sub End If End If End Sub

Try Sub Test() Debug.Print SubtractDigits("18538964") End Sub Function SubtractDigits(ByVal s As String) As Integer Dim i As Long, d As Long, r As Long For i = 1 To Len(s) d = CInt(Mid(s, i, 1)) - r r = Abs(d) Next i SubtractDigits = r End Function

Look you have to be more logical The total of the numbers in column B equals 331 so the final output number of the names will be 331 While the number of cells in range D2:H66 will be 65 * 5 which equals 325 so the cells that will be have the names are less than the needed names to be populated Can you explain how will you deal with the problem in that case

The pivottable in worksheet Total is working well. What's the problem

Please the topic needs more details and put some of the expected output

Before this line shTarget.Range(columnMappings(i)).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr you can add this line shTarget.Range(columnMappings(i)).Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents

Try Sub Test() Dim colSource, colTarget, ws As Worksheet, sh As Worksheet, lr As Long Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) lr = ws.Cells(Rows.Count, "C").End(xlUp).Row colSource = Array("C:E", "H", "K", "F") colTarget = Array("D10", "L10", "N10", "P10") PopulateArray ws, sh, 14, lr, colSource, colTarget End Sub Public Sub PopulateArray(ByVal wsSource As Worksheet, ByVal shTarget As Worksheet, ByVal sRow As Long, ByVal lr As Long, ByVal rangesToPopulate, ByVal columnMappings) Dim arr, rangeColumns, rng As Range, i As Long Application.ScreenUpdating = False For i = LBound(rangesToPopulate) To UBound(rangesToPopulate) If InStr(1, rangesToPopulate(i), ":") > 0 Then rangeColumns = Split(rangesToPopulate(i), ":") Set rng = wsSource.Range(rangeColumns(0) & sRow & ":" & rangeColumns(1) & lr) Else Set rng = wsSource.Range(rangesToPopulate(i) & sRow).Resize(lr - sRow + 1) End If arr = rng.Value shTarget.Range(columnMappings(i)).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr Next i Application.ScreenUpdating = True End Sub

You can use simple function here which is COUNTA