lionheart

Private Sub Worksheet_Change(ByVal Target As Range) Dim sCompany As String, m As Long If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Address = "$D$5" Then sCompany = Target.Value If Evaluate("ISREF('" & sCompany & "'!A1)") Then With Sheets(sCompany) m = .Cells(Rows.Count, "D").End(xlUp).Row + 1 .Range("D" & m).Resize(1, 4).Value = Application.Transpose(Range("M7:M10").Value) MsgBox "Data Copied To [ " & .Name & " ] Worksheet", 64 End With End If End If End Sub

We are in 2021 and you are still using 2007. I advise you to upgrade to 2019 or office 365

Private Sub ComboBox1_Change() Const iCols As Integer = 11 Dim a(1 To 1000, 1 To iCols), b(), rng As Range, c As Range, i As Long, ii As Long With Sheets(1) Set rng = .Range("B3:M" & .Cells(Rows.Count, "B").End(xlUp).Row) rng.AutoFilter Field:=12, Criteria1:=ComboBox1.Value On Error Resume Next Set rng = .Range("B3").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible) On Error GoTo 0 End With If Not rng Is Nothing Then For Each c In rng i = i + 1 For ii = LBound(a, 2) To UBound(a, 2) a(i, ii) = c.Offset(, ii - 1).Value Next ii Next c b = Application.Transpose(a) i = Application.Min(UBound(a, 1), i) ReDim Preserve b(1 To iCols, 1 To i) b = Application.Transpose(b) ListBox1.List = b End If End Sub

So simple. Do it yourself Create a variable and name it for example counter Then inside the loop and before the line that populates the value "Total" increase the variable by one like that counter = counter + 1 And finally put the ampersand symbol after the word "Total" and the variable name which is counter. That's all

Rename the data sheet to Data and create another sheet and name it Result OR change the sheet names in the code Sub Test() Const lRows As Long = 20, lCols As Long = 13 Dim ws As Worksheet, sh As Worksheet, rHeaders As Range, r As Long, lr As Long, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("Data") Set sh = ThisWorkbook.Worksheets("Result") sh.Cells.Clear Set rHeaders = ws.Range("A1:M1") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row For r = 2 To lr Step lRows m = sh.Cells(Rows.Count, "H").End(xlUp).Row + 1 m = IIf(m = 2, 1, m) rHeaders.Copy sh.Range("A" & m) With sh.Range("I" & m) .Interior.Color = vbYellow .Offset(, 2).Interior.Color = vbYellow End With ws.Range("A" & r).Resize(lRows, lCols).Copy sh.Range("A" & m + 1) With sh.Range("H" & m + lRows + 1) .Value = "Total": .Font.Bold = True .Offset(, 1).Formula = "=SUM(R[-1]C:R[-" & lRows & "]C)" .Offset(, 3).Formula = "=SUM(R[-1]C:R[-" & lRows & "]C)" .Resize(1, 4).Interior.Color = vbYellow End With Next r With sh.Cells .FormatConditions.Delete: .ReadingOrder = xlRTL .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .RowHeight = 23 .Columns(9).ColumnWidth = 10 .Columns(11).ColumnWidth = 14 .Font.Size = 14: .Font.Name = "Arial" End With Application.CutCopyMode = False On Error Resume Next sh.Range("I" & m & ":I" & m + lRows + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete On Error GoTo 0 sh.Range("A1").CurrentRegion.Borders.Value = 1 Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

Look my bro. You have wasted my time, I have told you that you have to comment out two specific lines and you didn't do that. Then I have modified the code for you and expected from you to copy the new code but it seems you didn't do that Please back to the code and copy it again to your file and test the code for last time.

The code is working fine for me, please review the modified code in my main post If there are more problems, please attach your file with real data.

Delete the lines I referred to in the code

Try comment out these two lines If i = n Then .... End If

Draw any shape > Right-Click on it > Assign Macro . Select he macro name. It is not difficult at all

Change the worksheets names according to your file Sub Test() Const nRows As Long = 25 Const sCells As String = "B5,D5,F5" Dim x, a, t, ws As Worksheet, sh As Worksheet, rng As Range, r As Range, lr As Long, n As Long, i As Long, m As Long, ii As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("Names") Set sh = ThisWorkbook.Worksheets("Lists") sh.Range("B5:B29,D5:D29,F5:F25").ClearContents x = Application.Match(sh.Range("G1").Value, ws.Rows(1), 0) If Not IsError(x) Then lr = ws.Cells(Rows.Count, x).End(xlUp).Row If lr < 4 Then MsgBox "No Data", vbExclamation: Exit Sub Set rng = ws.Range(ws.Cells(4, x), ws.Cells(lr, x)) If rng.Rows.Count > 75 Then MsgBox "No Place For All Data", vbExclamation: Exit Sub rng.Sort Key1:=ws.Cells(4, x), Order1:=xlAscending, Header:=xlNo a = rng.Value n = UBound(Split(sCells, ",")) + 1 For i = 1 To n Set r = sh.Range(Split(sCells, ",")(i - 1)) t = Slice(a, m, m + nRows - 1) m = m + nRows For ii = UBound(t) To LBound(t) Step -1 If IsError(t(ii)) Then t(ii) = Empty Else Exit For Next ii r.Resize(UBound(t)).Value = Application.Transpose(t) Set r = Nothing Next i End If Application.ScreenUpdating = True End Sub Function Slice(ByVal arr, ByVal f, ByVal t) Slice = Application.Index(arr, Evaluate("Transpose(Row(" & f + 1 & ":" & t + 1 & "))")) End Function

Sub Test() Dim x, y, sh As Worksheet, lr As Long, i As Long, cnt As Long With Sheet1 lr = .Cells(Rows.Count, 1).End(xlUp).Row For i = 4 To lr If .Cells(i, 1).Value <> "" And .Cells(i, 7).Value <> "" Then If InStr(.Cells(i, 7).Value, Chr(219) & Chr(237) & Chr(209)) Then Set sh = Sheet3 ElseIf InStr(.Cells(i, 7).Value, Chr(227) & Chr(196) & Chr(222) & Chr(202)) Then Set sh = Sheet4 Else Set sh = Sheet2 End If x = Application.Match(.Cells(i, 1).Value, sh.Columns(1), 0) If Not IsError(x) Then y = Application.Match(.Range("G3").Value2, sh.Rows(3), 0) If Not IsError(y) Then sh.Cells(x, y).Value = "*" cnt = cnt + 1 End If End If End If Next i End With MsgBox "Transferred Successfully = " & cnt, 64 End Sub

Suppose date in cell A1, put the following formula in C1 and drag =IF(WORKDAY.INTL($A$1-1,COLUMN(A1),"0000110")>EOMONTH($A$1,0),"",WORKDAY.INTL($A$1-1,COLUMN(A1),"0000110")

It is simple my bro Press Alt + F11 -- From Insert select Module -- Paste the code Back to worksheet -- Press Alt + F8 -- Click Run

There are 52 names in your file not 50 names. It seems you forgot to put a sequence numbers for two students Try the following code Sub Test() Dim lr As Long, r As Long, m As Long Application.ScreenUpdating = False With Sheet1 lr = .Cells(Rows.Count, "B").End(xlUp).Row m = 3 For r = 3 To lr .Cells(m, 6).Value = .Cells(r, 2).Value .Cells(m, 7).Value = .Cells(r, 3).Value m = m + 3 Next r End With Application.ScreenUpdating = True End Sub

Private Sub CommandButton1_Click() Dim ctrl As Control, cnt As Long For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then If IsNumeric(ctrl.Value) Then cnt = cnt + 1 End If Next ctrl MsgBox "TextBoxes With Numbers = " & cnt End Sub

=SUMPRODUCT(0+(CELL("width",OFFSET(B2,,N(INDEX(COLUMN(B2:G2)-MIN(COLUMN(B2:G2)),,))))>0),B2:G2)

Sub Test() Dim x, ws As Worksheet, sh As Worksheet, r As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) For r = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row x = Application.Match(sh.Cells(r, 1).Value, ws.Columns(2), 0) If Not IsError(x) Then sh.Range("H" & r).Resize(1, 3).Value = ws.Range("K" & x).Resize(1, 3).Value End If Next r Application.ScreenUpdating = True End Sub

The question is not logical as there are many difference in the inputs in the two columns That's my try but of course not the perfect solution Sub Test() Dim e, x, r As Range, c As Range, s As String, v As String, t As String, b As String, d As String, f As String Application.ScreenUpdating = False With ActiveSheet.UsedRange .Columns(3).Interior.Color = xlNone .Columns(14).Interior.Color = xlNone For Each c In .Columns(14).Cells If c.Value = "" Then GoTo iNext b = Replace(c.Value, Chr(218) & Chr(200) & Chr(207) & Chr(32) & Chr(199), Chr(218) & Chr(200) & Chr(207) & Chr(199)) x = Split(b) d = x(0) & Space(1) & x(1) & Space(1) & x(2) b = Replace(c.Value, Chr(236), Chr(237)) x = Split(b) f = x(0) & Space(1) & x(1) & Space(1) & x(2) x = Split(c.Value) v = x(0) & Space(1) & x(1) & Space(1) & x(2) t = Replace(v, Chr(201), Chr(229)) With .Columns(3) For Each e In Array(t, v, d, f) Set r = .Find(e, , xlValues, xlPart) If Not r Is Nothing Then s = r.Address Do r.Interior.Color = vbYellow Rem c.Interior.Color = vbRed Set r = .Find(e, , xlValues, xlPart) Loop Until r.Address = s Set r = Nothing End If Next e End With iNext: Next c End With Application.ScreenUpdating = True End Sub

Give me examples of the uncolored rows

Press Alt + F11 when you are in the worksheet then from Insert menu in the VBE select module and at last paste the code To run the code press Alt F8 while you are in the worksheet and select the macro named Test and finally click Run I think it is better to learn the VBA basics first before posting questions

Sub Test() Dim r As Range, c As Range, s As String Application.ScreenUpdating = False With ActiveSheet.UsedRange .Columns(3).Interior.Color = xlNone .Columns(14).Interior.Color = xlNone For Each c In .Columns(14).Cells If c.Value = "" Then GoTo iNext With .Columns(3) Set r = .Find(c.Value, , xlValues, xlPart) If Not r Is Nothing Then s = r.Address Do r.Interior.Color = vbYellow c.Interior.Color = vbRed Set r = .Find(c.Value, , xlValues, xlPart) Loop Until r.Address = s Set r = Nothing End If End With iNext: Next c End With Application.ScreenUpdating = True End Sub

Sub Test() Dim a, ws As Worksheet, sh As Worksheet, i As Long Set ws = ThisWorkbook.Worksheets("Sheet1") Set sh = ThisWorkbook.Worksheets("Sheet2") With ws a = Array(Empty, .Range("C11").Value, .Range("C9").Value, .Range("C6").Value, .Range("C12").Value, .Range("C8").Value) End With With sh.ListObjects(1) For i = 1 To .ListRows.Count If Application.CountA(.ListRows(i).Range) = 0 Then Exit For Next i If i > .ListRows.Count Then .ListRows.Add .ListRows(i).Range.Value = a End With End Sub

Sub Test() Dim a, ws As Worksheet, sh As Worksheet, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) a = ws.Range("B6:M" & ws.Cells(Rows.Count, "C").End(xlUp).Row).Value a = Application.Index(a, Evaluate("ROW(1:" & UBound(a, 1) & ")"), [{1,2,3,6,9,10,11,12}]) 'first empty row (new line added) m = sh.Cells(Rows.Count, 2).End(xlUp).Row + 1 'change 7 in the following two lines to use the variable m instead sh.Range("A" & m).Resize(UBound(a, 1), UBound(a, 2)).Value = a sh.Range("I" & m).Resize(UBound(a, 1)).Value = ws.Range("C4").Value Application.ScreenUpdating = True End Sub

So simple. remove the line of clearcontents sh.Range("A7:I" & Rows.Count).ClearContents then specify the destination by detecting the last row. I will leave that for you. Don't wait others to do everything for you