lionheart

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

Sub Test() Dim a, ws As Worksheet, sh As Worksheet 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}]) sh.Range("A7:I" & Rows.Count).ClearContents sh.Range("A7").Resize(UBound(a, 1), UBound(a, 2)).Value = a sh.Range("I7").Resize(UBound(a, 1)).Value = ws.Range("C4").Value Application.ScreenUpdating = True End Sub

Change the month on your side and test the code to see if it will be suitable for you or not

I am not sure I can get you but play around these two lines to reverse the values sh.Cells(v, x).Value = ws.Cells(r, 3).Value sh.Cells(v, x + 1).Value = ws.Cells(r, 2).Value

Sub Test() Dim v, x, ws As Worksheet, sh As Worksheet, dic As Object, sName As String, r As Long, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(2) Set sh = ThisWorkbook.Worksheets(3) Set dic = CreateObject("Scripting.Dictionary") m = 9 sh.Range("B9:DW66").ClearContents For r = 2 To ws.Cells(Rows.Count, "F").End(xlUp).Row sName = ws.Cells(r, 6).Value If Not dic.Exists(sName) Then dic(sName) = Empty sh.Cells(m, 2).Value = ws.Cells(r, 7).Value sh.Cells(m, 3).Value = ws.Cells(r, 6).Value m = m + 1 End If v = Application.Match(ws.Cells(r, 6).Value, sh.Columns(3), 0) If Not IsError(v) Then x = Application.Match(CLng(CDate(ws.Cells(r, 4).Value2)), sh.Rows(6), 0) If Not IsError(x) Then sh.Cells(v, x).Value = ws.Cells(r, 2).Value sh.Cells(v, x + 1).Value = ws.Cells(r, 3).Value End If End If Next r Application.ScreenUpdating = True End Sub

Sub Print6() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets If ws.Name = "Sheet1" Or ws.Name = "Sheet2" Or ws.Name = "Sheet3" Then ws.Range("A1:K" & ws.Cells(Rows.Count, "B").End(xlUp).Row).PrintOut End If Next End Sub

Option Explicit Private Sub CommandButton1_Click() UpdateListBox "WEEK 1" End Sub Private Sub CommandButton2_Click() UpdateListBox "WEEK 2" End Sub Private Sub CommandButton3_Click() UpdateListBox "WEEK 3" End Sub Private Sub CommandButton4_Click() UpdateListBox "WEEK 4" End Sub Sub UpdateListBox(ByVal sWeek As String) Dim ws As Worksheet, i As Long Set ws = ThisWorkbook.Worksheets(1) For i = 0 To UserForm1.ListBox1.ListCount - 1 If UserForm1.ListBox1.Selected(i) Then ListBox1.List(i, 4) = sWeek ws.Cells(i + 3, 11) = sWeek End If Next i Call CommandButton5_Click End Sub Private Sub CommandButton5_Click() Dim deg1, deg4, deg6, deg8, deg2 As String, deg3 As String, deg5 As String, deg7 As String, sat As Long, s As Long With Application .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With With ListBox1 .Clear .ColumnCount = 8 .ColumnWidths = "80;190;100;80;0;110,100" End With deg2 = "AUGUST" deg3 = "AUGUST" deg5 = "AUGUST" deg7 = "AUGUST" For sat = 3 To Sheet1.Cells(65536, "F").End(xlUp).Row Set deg1 = Sheet1.Cells(sat, "F") Set deg4 = Sheet1.Cells(sat, "G") Set deg6 = Sheet1.Cells(sat, "H") Set deg8 = Sheet1.Cells(sat, "I") If UCase(deg1) Like UCase(deg2) Or UCase(deg3) Like UCase(deg4) Or UCase(deg5) Like UCase(deg6) Or UCase(deg7) Like UCase(deg8) Then ListBox1.AddItem ListBox1.List(s, 0) = Sheet1.Cells(sat, "A").Value ListBox1.List(s, 1) = Sheet1.Cells(sat, "C").Value ListBox1.List(s, 2) = Sheet1.Cells(sat, "B").Value ListBox1.List(s, 3) = Sheet1.Cells(sat, "D").Value ListBox1.List(s, 5) = Sheet1.Cells(sat, "N").Value ListBox1.List(s, 6) = Sheet1.Cells(sat, "J").Value ListBox1.List(s, 7) = Sheet1.Cells(sat, "K").Value s = s + 1 End If Next sat With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .EnableEvents = True End With End Sub

The same idea my bro (not new solution at all) . Look carefully at my code at the last part.

Private Sub UserForm_Initialize() Rem 1 = Second Column In ListBox Const cToSum As Integer = 1 Dim arr(1 To 6, 1 To 3) As String, i As Long, j As Long, t As Long, d As Double For i = 1 To 6 For j = 1 To 3 t = Application.WorksheetFunction.RandBetween(-1, 1) If t = 0 Then t = 1 arr(i, j) = i * j * t Next j Next i With ListBox1 .Clear .ColumnCount = UBound(arr, 2) .List = arr() End With With ListBox1 For i = 0 To .ListCount - 1 If .List(i, cToSum) > 0 Then d = d + .List(i, cToSum) Next i TextBox1.Value = d End With End Sub

Sub Test() Dim r As Range, c As Long Application.ScreenUpdating = False With ActiveSheet Set r = .Range("L4:L" & .Cells(Rows.Count, "L").End(xlUp).Row) c = .Cells(4, Columns.Count).End(xlToLeft).Column + 1 .Cells(4, c).Resize(r.Rows.Count).Value = r.Value End With Application.ScreenUpdating = True End Sub

Sub Test() Dim s$ s = "D:\Programation\VISUAL STUDIO\Projectes\DATA.xls" MsgBox Split(s, "\")(UBound(Split(s, "\"))) End Sub

Private Sub TextBox1_Change() Dim dFrom As Date, dTo As Date, lr As Long With ActiveSheet lr = .Range("B" & Rows.Count).End(xlUp).Row If TextBox1.Text <> "" Then .AutoFilterMode = False dFrom = .Range("F1").Value2 dTo = .Range("G1").Value2 With .Range("B2:Q" & lr) .AutoFilter Field:=1, Criteria1:="=" & TextBox1.Text & "*", Operator:=xlOr .AutoFilter 8, ">=" & CLng(dFrom), xlAnd, "<=" & CLng(dTo) End With Else .AutoFilterMode = False End If End With End Sub

Sub Test() Dim a, v, w1 As Worksheet, w2 As Worksheet, dic As Object, s As String, i As Long, m As Long, cnt As Long Set w1 = Sheet1: Set w2 = Sheet2 Set dic = CreateObject("Scripting.Dictionary") a = w1.Range("A4").CurrentRegion.Value For i = 2 To UBound(a) s = a(i, 1) & Chr(2) & a(i, 2) & Chr(2) & a(i, 3) dic(s) = Empty Next i With w2 For i = 5 To .Cells(Rows.Count, 1).End(xlUp).Row s = Empty s = .Cells(i, 1) & Chr(2) & .Cells(i, 2) & Chr(2) & .Cells(i, 3) If Not dic.Exists(s) Then m = w1.Cells(Rows.Count, 1).End(xlUp).Row + 1 v = Split(s, Chr(2)) w1.Range("A" & m).Resize(1, 3).Value = v cnt = cnt + 1 End If Next i End With If cnt > 0 Then MsgBox "New Items Added = " & cnt, 64 Else MsgBox "No New Items", vbExclamation End Sub

Sub Test() Dim a a = GetDates(Range("D1").Value2, Range("F1").Value2) Range("D3").Resize(UBound(a)).Value = Application.Transpose(a) End Sub Function GetDates(ByVal startDate As Date, ByVal endDate As Date) Dim v() As Date, cnt As Long ReDim v(1 To CLng(endDate) - CLng(startDate) + 1) For cnt = LBound(v) To UBound(v) v(cnt) = CDate(startDate) startDate = CDate(CDbl(startDate) + 1) Next cnt GetDates = v If IsArray(v) Then Erase v cnt = Empty End Function or Sub Test() Dim sDate As Date, eDate As Date, r As Long sDate = Range("D1").Value2 eDate = Range("F1").Value2 Range("D3:D" & Rows.Count).ClearContents Do Until sDate > eDate r = r + 1 Range("D" & r + 2).Value = sDate sDate = sDate + 1 Loop End Sub

Not clear for me