lionheart

Sub Test() Dim a, b Application.ScreenUpdating = False With ActiveSheet a = .Range("C4:C43").Value CloneArray a, .Range("AV4"), 18, True b = Application.Transpose(Range("D3:U3").Value) CloneArray b, .Range("AW4"), UBound(a, 1), False End With Application.ScreenUpdating = True End Sub Sub CloneArray(ByVal arr, ByVal rngT As Range, ByVal n As Integer, ByVal allItems As Boolean) Dim i As Long, ii As Long, k As Long ReDim b(1 To UBound(arr, 1) * n, 1 To 1) If allItems Then For i = 1 To n For ii = LBound(arr, 1) To UBound(arr, 1) k = k + 1 b(k, 1) = arr(ii, 1) Next ii Next i Else For i = LBound(arr, 1) To UBound(arr, 1) For ii = 1 To n k = k + 1 b(k, 1) = arr(i, 1) Next ii Next i End If rngT.Resize(UBound(b, 1), UBound(b, 2)).Value = b End Sub

Sub Test() Dim a, e, c As Range, sCols As String, m As Long Application.ScreenUpdating = False With ActiveSheet m = .Cells(Rows.Count, 1).End(xlUp).Row + 10 With .Range("A1").CurrentRegion For Each c In .Rows(1).Cells If c.EntireColumn.Hidden Then sCols = sCols & IIf(sCols = "", "", "|") & c.Column Next c .EntireColumn.Hidden = False .Offset(1).SpecialCells(xlCellTypeVisible).Copy .Parent.Range("A" & m) End With With .Range("A" & m).CurrentRegion a = .Value: .Clear End With For Each e In Split(sCols, "|") .Columns(Val(e)).Hidden = True Next e End With Application.ScreenUpdating = True End Sub

NOT CLEAR AT ALL

Did you try the code on the same file you attached

As an idea, you can copy the visible cells to unused range then store the range into array Sub Test() Dim a, m As Long With ActiveSheet m = .Cells(Rows.Count, 1).End(xlUp).Row + 10 .Range("A1").CurrentRegion.Offset(1).SpecialCells(xlCellTypeVisible).Copy .Range("A" & m) a = .Range("A" & m).CurrentRegion.Value .Range("A" & m).CurrentRegion.Clear End With End Sub

Sub Test() Dim rng As Range Application.ScreenUpdating = False With ActiveSheet Set rng = .Range("H2:L" & .Cells(Rows.Count, "H").End(xlUp).Row) With rng With .Columns(.Columns.Count) .Formula = "=MATCH(H2,B:B,0)" .Value = .Value rng.Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes .ClearContents End With End With End With Application.ScreenUpdating = True End Sub

Why five lines while it can be done in one line Me.TextBox1.Value = Cells(ActiveCell.Row, 1).Value

What's your OS? Is OS 32bit or 64bit What's Office version Can you attach the file with the code you are trying to execute to test on my side

Sub Test() Dim ws As Worksheet, sh As Worksheet, rRange As Range, rCell As Range, rng As Range, t As Double, iRow As Long, r As Long, c As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(2) 'Tasks Set sh = ThisWorkbook.Worksheets(1) 'Summary iRow = 4: r = iRow With sh.Rows(iRow + 1 & ":" & Rows.Count) .ClearContents: .Borders.Value = 0 End With Set rRange = ws.Range("B5:B" & ws.Cells(Rows.Count, "B").End(xlUp).Row) Set rCell = rRange.Cells(1, 1) Do If rCell.Value = Chr(199) & Chr(225) & Chr(199) & Chr(204) & Chr(227) & Chr(199) & Chr(225) & Chr(237) Or rCell.Value = Empty Then GoTo NXT r = r + 1: t = 0 sh.Cells(r, 1).Value = r - iRow sh.Cells(r, 2).Value = rCell.Value For c = 3 To 16 Set rng = rCell.Offset(, c - 2).Resize(rCell.MergeArea.Rows.Count) t = Application.WorksheetFunction.Sum(rng) If t = 0 Then sh.Cells(r, c).Value = Empty Else sh.Cells(r, c).Value = t Next c NXT: Set rCell = rCell.Offset(1, 0) Set rng = Nothing Loop Until (rCell.Row > (rRange.Row + rRange.Rows.Count - 1)) With sh.Rows(iRow + 1 & ":" & r) .Borders.Value = 1 End With Application.ScreenUpdating = True End Sub

Congratulations my brother

Suppose you have data in range A1 to B20 (Names in first column & Age in second column) Names Age John 41 john 52 Junior 46 junior 37 Lion 33 Lion Heart 15 lion 58 lion heart 39 heart 24 Heart 35 My Heart 18 my heart 14 In cell E1 type the formula (for 365 users) =IF(D1="","",FILTER(A2:B20,ISNUMBER(FIND(D1,A2:A20)),"No Results")) Now you can type in cell D1 File.xlsx

The OP is not clear in the issue and he doesn't respond properly I have posted a nother different code based on his last comments

No worry my brother I thought the OP selects the answer and not the moderator (How can I know such things?) Sometimes the members take more than a solution so they continue to discuss Ramadan Karim

Sub Test() Dim x, ws As Worksheet, wsData As Worksheet, wsSource As Worksheet, wsA As Worksheet, wsF As Worksheet, wsM As Worksheet, r As Long, lr As Long Application.ScreenUpdating = False Set wsData = ThisWorkbook.Worksheets("Data") Set wsSource = ThisWorkbook.Worksheets("Feuil1") Set wsA = ThisWorkbook.Worksheets("ARABE") Set wsF = ThisWorkbook.Worksheets("FRANCAIS") Set wsM = ThisWorkbook.Worksheets("MIXTE") For Each ws In ThisWorkbook.Worksheets If ws Is wsA Or ws Is wsF Or ws Is wsM Then ws.Cells.ClearContents ws.Range("A1").Resize(, 7).Value = wsData.Range("A1").Resize(, 7).Value End If Next ws For r = 2 To wsSource.Cells(Rows.Count, 1).End(xlUp).Row x = Application.Match(wsSource.Cells(r, 1).Value, wsData.Columns(1), 0) If Not IsError(x) Then With ThisWorkbook.Worksheets(CStr(wsData.Cells(x, 8).Value)) lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1 .Range("A" & lr).Resize(, 7).Value = wsSource.Range("A" & r).Resize(, 7).Value End With End If Next r Application.ScreenUpdating = True End Sub

@omar elhosseini Did you try the code to decide if it is working or not The only one who can decide that is the OP not YOU and when you call someone, call him with his name not just a member

Sub Test() Dim a, x, e, v, wsData As Worksheet, wsExisting As Worksheet, wsA As Worksheet, wsF As Worksheet, wsM As Worksheet, sh As Worksheet, i As Long, ii As Long, k1 As Long, k2 As Long, k3 As Long, n As Long Application.ScreenUpdating = False Set wsData = ThisWorkbook.Worksheets("Data") Set wsExisting = ThisWorkbook.Worksheets("Feuil1") Set wsA = ThisWorkbook.Worksheets("ARABE") Set wsF = ThisWorkbook.Worksheets("FRANCAIS") Set wsM = ThisWorkbook.Worksheets("MIXTE") a = wsData.Range("A2:H" & wsData.Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim b1(1 To UBound(a, 1), 1 To UBound(a, 2) - 1) ReDim b2(1 To UBound(a, 1), 1 To UBound(a, 2) - 1) ReDim b3(1 To UBound(a, 1), 1 To UBound(a, 2) - 1) For i = LBound(a, 1) To UBound(a, 1) x = Application.Match(a(i, 1), wsExisting.Columns(1), 0) If Not IsError(x) Then GoTo NXT If a(i, 8) = "ARABE" Then k1 = k1 + 1 For ii = 1 To 7 b1(k1, ii) = a(i, ii) Next ii ElseIf a(i, 8) = "FRANCAIS" Then k2 = k2 + 1 For ii = 1 To 7 b2(k2, ii) = a(i, ii) Next ii ElseIf a(i, 8) = "MIXTE" Then k3 = k3 + 1 For ii = 1 To 7 b3(k3, ii) = a(i, ii) Next ii End If NXT: Next i For Each e In Array(1, 2, 3) If e = 1 Then Set sh = wsA: n = k1: v = b1 ElseIf e = 2 Then Set sh = wsF: n = k2: v = b2 ElseIf e = 3 Then Set sh = wsM: n = k3: v = b3 End If If n > 0 Then sh.Range("A1").CurrentRegion.ClearContents sh.Range("A1").Resize(, 7).Value = wsData.Range("A1").Resize(, 7).Value sh.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v End If Next e Application.ScreenUpdating = True End Sub

I am so sorry as I don't attach any files at all Wait for someone who can do that for you GenerateUniqueRandom ActiveSheet, "D3:F22", Range("A1").Value, Range("A2").Value

Replace the number with the cell value. What's difficult at this point replace the number 1 with range("A1").value for example

Sub Test() Dim m As Long m = Cells(Rows.Count, 1).End(xlUp).Row + 1 Rows(m & ":" & Rows.Count).Clear End Sub

Without any code, you can do it in few steps Filter the column by the word TOTAL then select the rows and delete. That's all

You can do that by sorting the listbox itself As for the second note, use the variable k to start equal to 1 then increment by one

It seems you didn't try my code well. Have a look at this line of code If c = 3 Then .Text = .Text Else .Value = .Value

Option Explicit Private Sub CommandButton1_Click() Dim ws As Worksheet, i As Long, k As Long For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.Selected(i) Then k = k + 1 Set ws = Worksheets(Me.ListBox1.List(i, 0)) ws.Move Before:=ThisWorkbook.Worksheets(k) End If Next i End Sub Private Sub UserForm_Activate() Dim ws As Worksheet With Me.ListBox1 .Clear For Each ws In Worksheets .AddItem ws.Name Next ws End With End Sub

Sub Test() Dim rng As Range, c As Long Application.ScreenUpdating = False Set rng = Range("A5:J" & Cells(Rows.Count, "D").End(xlUp).Row) rng.UnMerge For c = 1 To rng.Columns.Count With rng.Columns(c) On Error Resume Next .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C" If c = 3 Then .Text = .Text Else .Value = .Value On Error GoTo 0 End With Next c Application.ScreenUpdating = True End Sub

Sub Test() GenerateUniqueRandom ActiveSheet, "D3:F22", 1, 60 End Sub Sub GenerateUniqueRandom(ByVal shTarget As Worksheet, ByVal sRng As String, ByVal iStart As Long, iEnd As Long) Dim w, v, rng As Range, c As Range, n As Long, i As Long, ii As Long, r As Long Set rng = shTarget.Range(sRng) If iEnd - iStart + 1 > rng.Cells.Count Then MsgBox "Generated Numbers Greater Than Range Cell Count", vbExclamation: Exit Sub w = Evaluate("ROW(" & iStart & ":" & iEnd & ")") n = 0 ReDim v(1 To rng.Rows.Count, 1 To rng.Columns.Count) For i = LBound(v, 1) To UBound(v, 1) For ii = LBound(v, 2) To UBound(v, 2) r = Application.RandBetween(iStart, UBound(w) - n) v(i, ii) = w(r, 1) w(r, 1) = w(UBound(w) - n, 1) n = n + 1 Next ii Next i rng.Cells(1).Resize(UBound(v, 1), UBound(v, 2)).Value = v End Sub