lionheart

You can use helper column as you can't directly use SUBTOTAL with COUNTIF but you can achieve that using SUMPRODUCT approach Suppose you have names in range B2:B6 and you want to count if the name starts with [Kh] letters Now you can try this formula =SUMPRODUCT(SUBTOTAL(103, OFFSET(B2:B6, ROW(B2:B6)-MIN(ROW(B2:B6)), 0, 1)) * EXACT(LEFT(B2:B6, 2), "Kh"))

Try this code Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Boolean Sub Export_Range_As_Picture() Dim ws As Worksheet, oRng As Range, oChart As ChartObject, sFolder As String, sFile As String, rw As Long Application.ScreenUpdating = False Set ws = Sheet1 sFolder = "D:\Pic\" MakeSureDirectoryPathExists sFolder sFile = sFolder & ws.Range("A1").Value & "." & "jpg" rw = FindErrorRow(ws, 2) If rw <> -1 Then Set oRng = ws.Range("A2:E" & rw) Else Set oRng = ws.Range("A2:E" & ws.Cells(Rows.Count, "B").End(xlUp).Row) End If oRng.CopyPicture xlScreen, xlPicture Set oChart = ws.ChartObjects.Add(Left:=0, Top:=0, Width:=oRng.Width * 1, Height:=oRng.Height * 1) With oChart .Activate .Chart.Paste .Chart.Export Filename:=sFile .Delete End With Application.ScreenUpdating = True MsgBox "Done", 64 End Sub Function FindErrorRow(ByVal ws As Worksheet, ByVal col As Long) Dim rng As Range On Error Resume Next Set rng = ws.Columns(col).SpecialCells(xlCellTypeFormulas, xlErrors) On Error GoTo 0 If Not rng Is Nothing Then FindErrorRow = rng.Cells(1, 1).Row - 1 Else FindErrorRow = -1 End Function

Right-Click on the cell >> Format Cells From Category select Number >> Change Decimal places to 2

Hello Nabil Try this code Sub Move_PDF_Files() Dim ws As Worksheet, sDesktop As String, srcFolder As String, desFolder As String, empName As String, sFile As String, TargetFolder As String, lr As Long, r As Long Set ws = ThisWorkbook.Sheets("Sheet1") sDesktop = Environ("UserProfile") & "\Desktop\" srcFolder = sDesktop & "SourceFolder\" desFolder = sDesktop & "DestinationFolder\" If Dir(desFolder, vbDirectory) = "" Then MkDir desFolder lr = ws.Cells(Rows.Count, "E").End(xlUp).Row For r = 2 To lr empName = ws.Cells(r, "E").Value sFile = empName & ".pdf" TargetFolder = desFolder & empName & "\" If Dir(TargetFolder, vbDirectory) = "" Then MkDir TargetFolder If Dir(srcFolder & sFile) <> "" Then FileCopy srcFolder & sFile, TargetFolder & sFile Else Debug.Print "File [" & sFile & "] Not Found In Source Folder" End If Next r MsgBox "PDF Files Moved Successfully!", 64 End Sub This is for illustration

Try this instead Function MyRound(ByVal mainVal As Double, ByVal roundVal As Double) As Double Dim h As Double, v As Double On Error GoTo ErrSub h = roundVal / 2 If mainVal >= 0 Then If (mainVal Mod roundVal) >= h Then v = Application.WorksheetFunction.RoundUp(mainVal / roundVal, 0) * roundVal Else v = Application.WorksheetFunction.RoundDown(mainVal / roundVal, 0) * roundVal End If End If MyRound = v Exit Function ErrSub: MsgBox Err.Number & vbCrLf & Err.Description, vbCritical + vbMsgBoxRight MyRound = 0 End Function

Try this code Sub Test() Const SROW As Long = 6 Dim w, m As Long, r As Long, n As Long Application.ScreenUpdating = False With ActiveSheet .Columns("L:M").ClearContents m = SROW For r = SROW To .Cells(Rows.Count, "J").End(xlUp).Row n = .Cells(r, "I").Value If n > 0 Then .Cells(m, "L").Resize(n).Value = .Cells(r, "J").Value m = m + n End If Next r m = m - SROW w = Evaluate("ROW(1:" & m & ")") .Range("M" & SROW).Resize(UBound(w, 1)).Value = w End With Application.ScreenUpdating = True End Sub

The code is already OK as it exports data from the listbox to the worksheet Just comment out those two lines For X = 0 To ListBox1.ListCount - 1 Next X as I don't see any need to loop through the items of the listbox

In sheet [Template] put the formula in cell C3 =INDEX(Support!A:A,MATCH(Criteria,Support!B:B,0))

Try this formula =MID(LEFT(A1,LEN(A1)-6),5,LEN(LEFT(A1,LEN(A1)-6)))

Not so clear but try this code Sub Test() Dim a, letters, i As Long, ii As Long, k As Long a = Sheet1.Range("C1").CurrentRegion.Value Rem letters = Split("ا,أ,إ,آ", ",") letters = Split("ب", ",") ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) For i = 2 To UBound(a, 1) If IsNumeric(Application.Match(Left(a(i, 2), 1), letters, 0)) Then k = k + 1 For ii = LBound(a, 2) To UBound(a, 2) b(k, ii) = a(i, ii) Next ii End If Next i If k > 0 Then With Sheet2 .Columns("C:E").ClearContents .Range("C1").Resize(, 3).Value = Sheet1.Range("C1").Resize(, 3).Value .Range("C2").Resize(k, UBound(b, 2)).Value = b End With End If End Sub

Try to read the code to add a fourth column in the output. The code is so simple to read

Try Sub Test() Dim ws As Worksheet, m As Long, i As Long, ii As Long Application.ScreenUpdating = False Set ws = ActiveSheet: m = 2 With ws .Columns("K:M").Clear .Columns("M").ColumnWidth = 11 With .Range("K1").Resize(, 3) .Value = Array("Group", "Number", "Work Date") .Interior.Color = RGB(146, 205, 220) .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With For i = 2 To 6 If .Cells(i, 2).Value < .Cells(i, 3).Value And IsNumeric(.Cells(i, 2).Value) And IsNumeric(.Cells(i, 2).Value) Then For ii = .Cells(i, 2).Value To .Cells(i, 3).Value .Cells(m, "K").Resize(, 3).Value = Array(.Cells(i, 1).Value, ii, .Cells(i, 4).Value) m = m + 1 Next ii End If Next i End With Application.ScreenUpdating = True End Sub

Do it yourself Press Alt + F11 >> Insert Module >> Paste the code

Try this code Sub Test() Dim ws As Worksheet, fso As Object, sPath As String, lr As Long, iRow As Long Set ws = ActiveSheet Set fso = CreateObject("Scripting.FileSystemObject") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row ws.Columns(1).Interior.Color = xlNone For iRow = 2 To lr sPath = ThisWorkbook.Path & "\" & ws.Cells(iRow, 1).Value If fso.FolderExists(sPath) Then ws.Cells(iRow, 1).Interior.Color = vbGreen End If Next iRow End Sub

Here's a version that merges cells although I see not practical and not useful later Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, n As Long, i As Long, c As Long Set ws = ThisWorkbook.Worksheets("1") Set sh = ThisWorkbook.Worksheets("2") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then Exit Sub m = 5: n = m Application.ScreenUpdating = False Application.DisplayAlerts = False With sh.Rows("5:" & Rows.Count) .ClearContents: .Borders.Value = 0: .UnMerge: .RowHeight = 20.25 End With For r = 6 To lr If ws.Cells(r, 4).Value > 0 Then For i = 1 To ws.Cells(r, 4).Value sh.Cells(m, 1).Value = ws.Cells(r, 2).Value sh.Cells(m, 2).Value = ws.Cells(r, 3).Value sh.Cells(m, 3).Value = ws.Cells(r, 4).Value sh.Cells(m, 4).Value = ws.Range("D3").Value & ws.Cells(r, 1).Value & ws.Cells(r, 2).Value & i m = m + 1 Next i For c = 1 To 3 With sh.Range(sh.Cells(n, c), sh.Cells(m - 1, c)) .Merge: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Next c If lr = r Then Exit For sh.Cells(m, 1).Resize(, 4).Interior.Color = vbMagenta m = m + 1 n = m End If Next r sh.Range("A5:F" & m - 1).Borders.Value = 1 Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub