lionheart

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

Target(2, 1).Resize(1, 8).Interior.Color = &HFF00& Target(2, 1).Offset(, 1).Resize(1, 4).Merge

No clear logic

The code is working on the attached file

Sub Test() Dim w1 As Worksheet, w2 As Worksheet, c As Range, n As Long Set w1 = Sheets("2020"): Set w2 = Sheets("2021") n = w2.Cells(Rows.Count, 1).End(xlUp).Row + 1 For Each c In w1.Range("A5").CurrentRegion.Columns(5).Cells If c.Value = "Active" Then w2.Range("A" & n).Resize(1, 5).Value = c.Offset(, -4).Resize(1, 5).Value n = n + 1 End If Next c End Sub

Sub pastespc() Dim t As Long, r As Long, m As Long lr = Range("d" & Rows.Count).End(3).Row + 5 t = lr Range("a1:e34").Copy Range("a" & lr) m = Range("d" & Rows.Count).End(3).Row For r = m To t + 5 Step -1 If Application.CountA(Range("A" & r).Resize(1, 4)) = 0 Then Range("A" & r).Resize(1, 5).Delete End If Next r If Cells(8, 2) <> "" Then lrr2 = Range("h" & Rows.Count).End(xlUp).Row + 1 Else lrr2 = Range("h" & Rows.Count).End(xlUp).Row + 1 ActiveSheet.Hyperlinks.Add anchor:=Cells(lrr2, 8), Address:="", SubAddress:="ÝÇÊæÑÉ!" & "e" & lr + 2 End If Cells(lrr2, 8) = [e3] Cells(lrr2, 9) = [c5] Cells(lrr2, 10) = [b7] Cells(lrr2, 11) = [e32] [e3] = [e3] + 1 End Sub

Try by yourself first and then write your notes. I will not waste my time with unclear topics

Sub Test() Dim x, ws As Worksheet, sh As Worksheet, s As String, m As Long Application.ScreenUpdating = False Set ws = Worksheets(1) Set sh = Worksheets(2) sh.Range("B7:B" & Rows.Count).ClearContents s = sh.Range("AI3").Value If s = "" Then MsgBox "Select Grade First", vbExclamation: Exit Sub x = Application.Match(s, ws.Rows(1), 0) If IsError(x) Then MsgBox "No Data For This Grade", vbExclamation: Exit Sub m = ws.Cells(Rows.Count, x).End(xlUp).Row If m < 4 Then MsgBox "No Data", vbExclamation: Exit Sub sh.Range("B7").Resize(m - 3).Value = ws.Cells(4, x).Resize(m - 3).Value Application.ScreenUpdating = True End Sub

Sub Test() Dim ws As Worksheet, sh As Worksheet, n As Long, r As Long Application.ScreenUpdating = False Set ws = Worksheets(2) Set sh = Worksheets(3) n = sh.Cells(Rows.Count, 2).End(xlUp).Row + 1 For r = 8 To 13 If ws.Cells(r, 1).Value <> "" Then sh.Cells(n, 2).Resize(1, 3).Value = Array(ws.Range("D4").Value, ws.Range("H4").Value, ws.Range("D5").Value) sh.Cells(n, 5).Value = ws.Cells(r, 1).Value sh.Cells(n, 6).Resize(1, 3).Value = ws.Cells(r, 4).Resize(1, 3).Value sh.Cells(n, 9).Value = ws.Cells(r, 8).Value sh.Cells(n, 10).Value = ws.Range("C18").Value sh.Cells(n, 11).Value = ws.Range("C19").Value sh.Cells(n, 12).Value = ws.Range("A21").Value sh.Cells(n, 13).Value = ws.Range("D21").Value sh.Cells(n, 14).Value = ws.Range("F21").Value sh.Cells(n, 15).Value = ws.Range("H21").Value sh.Cells(n, 16).Value = ws.Range("I21").Value sh.Cells(n, 17).Value = ws.Range("C36").Value sh.Cells(n, 18).Value = ws.Range("C37").Value sh.Cells(n, 19).Value = ws.Range("I36").Value n = n + 1 End If Next r Application.ScreenUpdating = True End Sub

No clear logic in your request Look at rows 2 and 3, there are some columns with different data so how will you deal with such case It will be better to put some of the expected results

=IFERROR(IF(ISODD(MID(C182,13,1)),"ذكر","أنثي"),"")

It seems Evaluate doesn't work in access (I am not sure) but to try add dot before Evaluate .Evaluate Another try add Application before it Application.Evaluate

I have no idea about the expected output. Attach an image of the expected output exactly

What about this code Sub Test() Dim w w = Evaluate("ROW(1:" & .Cells(.Rows.Count, "B").End(xlUp).Row - 1 & ")") .Range("A2").Resize(UBound(w, 1)).Value = w End Sub