lionheart

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

Where do you put the code, in excel or access If in excel, press Alt + F11 to open VBE editor and insert Module from insert menu and paste the code First clear the contents from A2 to A and the last row before running the code I posted before

Attach your file please

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

Thank you very much every body for your encouragement