lionheart

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

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