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

Here's a modification to let empty row between results but I won't merge cells Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, i 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 Application.ScreenUpdating = False 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 If lr = r Then Exit For sh.Cells(m, 1).Resize(, 4).Interior.Color = vbMagenta m = m + 1 End If Next r Application.ScreenUpdating = True End Sub

Delete the rows in sheet2 from row 5 to row 25 then try this code Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, i 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 Application.ScreenUpdating = False 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 End If Next r Application.ScreenUpdating = True End Sub I didn't merge the cells as it is not practical

Whar are the expected correct results exactly I have tried UDF on my side and these are the results 04-11-04 04-11-00 04-10-30 04-10-29 04-10-28 04-10-27 04-10-26

You have to create another worksheet and attach the file again with clear logic of what you are trying to do exactly Will the items be listed in the new worksheet or what

In cell B15 put the following formulas and drag to left =INDEX(OFFSET($E6, 1, 0, 1, COLUMNS($E6:$BH6)), MATCH(B14, OFFSET($E6, 0, 0, 1, COLUMNS($E6:$BH6)), 0)) then select the range B15:F15 and copy the range and finally paste the formulas into cells B17 then B19

You can execute the code in the worksheet event but I think it is better to execute the code for once when you would like to change

The error is because you have protected your worksheets so I think you encountered the error. To fix the problem just unprotect the worksheet before working on it and at the end to protect it again Sub HideRowsBasedOnCondition() Dim conditionValue, ws As Worksheet, conditionCell As Range, rowRange As Range For Each ws In ThisWorkbook.Sheets Set conditionCell = ws.Range("V1") conditionValue = conditionCell.Value ws.Unprotect ws.Rows.Hidden = False If conditionValue = 28 Then Set rowRange = ws.Rows("1363:1387") rowRange.Hidden = True ElseIf conditionValue = 29 Then Set rowRange = ws.Rows("1361:1362") rowRange.Hidden = True End If ws.Protect Next ws End Sub I just added two lines ws.Unprotect And ws.Protect

Is this problem related to a specific workbook or any workbook Attach the file if it is related to a sepcific workbook

What about Application.SendKeys "^f" DoEvents SendKeys "{NUMLOCK}{NUMLOCK}"

This line Application.Goto .Range("AM" & m), True is used to go to specific range. At the end of the code if the transfer process happens, excel will go to column AM at the row m so it is useful to see the results of the code