lionheart

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

You can change this line Set rng = Range("H9:N" & Cells(Rows.Count, "H").End(xlUp).Row) to Set rng = Selection Now you can select one cell or more and run the code to do the task for you

Try Sub Test() Const sRow As Long = 6 Dim a, b, x, rng As Range, sCol As String, lr As Long, i As Long Application.ScreenUpdating = False With ActiveSheet lr = .Cells(Rows.Count, "C").End(xlUp).Row Set rng = .Range("M3:V3") a = .Range("C" & sRow & ":C" & lr).Value b = .Range("L" & sRow & ":L" & lr).Value rng.Offset(1).Resize(lr - sRow + (sRow - rng.Row)).ClearContents For i = LBound(a) To UBound(a) x = Application.Match(a(i, 1), .Rows(rng.Row), 0) If Not IsError(x) Then .Cells(i + sRow - 1, x).Value = b(i, 1) Next i With rng.Offset(1) sCol = Split(rng.Cells(1).Address, "$")(1) .Formula = "=SUM(" & sCol & sRow & ":" & sCol & lr & ")" .Value = .Value End With End With Application.ScreenUpdating = True End Sub

Try Sub Test() Dim arr, rng As Range, i As Long, j As Long Set rng = Range("H9:N" & Cells(Rows.Count, "H").End(xlUp).Row) arr = rng.Value For i = LBound(arr, 1) To UBound(arr, 1) For j = LBound(arr, 2) To UBound(arr, 2) arr(i, j) = Round(arr(i, j) / 1000, 2) Next j Next i rng.Value = arr End Sub

I think you are not specific. You have to open a new topic with the new request

Do you mean that the worksheet Dashboard will be empty and you need to build the tables according to the first sheet or just a match You have to be clearer

You have to be specific from the beginning of the topic Sub Test() Dim lr As Long With ActiveSheet lr = Cells(Rows.Count, "C").End(xlUp).Row SumValuesBySearchKeys .Range("C6:C" & lr), .Range("L6:L" & lr), .Range("M3:V3") End With End Sub Public Sub SumValuesBySearchKeys(ByVal searchRange As Range, ByVal sumRange As Range, ByVal searchKeysRange As Range) Dim data(), a(), b(), out(), dic As Object, dataCols As Object, i As Long data = searchKeysRange.Value a = searchRange.Value b = sumRange.Value Set dic = CreateObject("Scripting.Dictionary") For i = LBound(a, 1) To UBound(a, 1) If Not dic.Exists(a(i, 1)) Then dic.Add a(i, 1), b(i, 1) Else dic(a(i, 1)) = dic(a(i, 1)) + b(i, 1) Next i ReDim out(1 To 1, 1 To UBound(data, 2)) Set dataCols = CreateObject("Scripting.Dictionary") For i = LBound(data, 2) To UBound(data, 2) If Not dataCols.Exists(data(1, i)) Then dataCols.Add data(1, i), i out(1, i) = dic(data(1, i)) Next i searchKeysRange.Offset(1, 0).Value = out End Sub