Today’s Date

Covert today’s date to text

Dim todayDate As String
        todayDate = Format(Now(), "mm/dd/yy")

'print ticket
        TimeOutWebQuery = 5
        TimeOutTime = DateAdd("s", TimeOutWebQuery, Now)
        Do Until appIE.readyState = 4
        If Now > TimeOutTime Then
            GoTo ErrorTimeOut
        End If
        appIE.ExecWB 6, 2
        Application.Wait (Now + TimeValue("0:00:03"))
        Set appIE= Nothing

Xs Range

Sub testfunction()

'Xs([A3], [namestas]) = "test"
Dim rngx As Range
    For Each rngx In Range(Xs([E3], [rdspac]), [E65536].End(xlUp))

                Xs(rngx, [namestas]) = "test ok"

    Next rngx
    MsgBox "OK"
End Sub


Transfer Date in PDF

if (this.getField("Today").value == "") {
    this.getField("Today").value = new Date();

Display 0 in accounting format

_($* #,##0.00_);_($* (#,##0.00);_($* 0.00_);_(@_)

Save as file

iPtr = InStrRev(ActiveWorkbook.FullName, ".")
  sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".csv"
  sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, FileFilter:="CSV (Comma delimited) (*.csv), *.csv")
  If sFileName = "False" Then Exit Sub

Split Macro

Split ( Expression, [Delimiter], [Limit], [Compare] )

Excel formula: If contains a value

Generic formula



If you want to copy cells that contain certain text, you can use a formula that uses the IF function together with the SEARCH and ISNUMBER functions. Once you find a value you’re looking for you can copy it to another location, or display a message, or perform some other calculation. Too complicated? Just need a formula for If cell equals? If cell contains “abc”, copy it elsewhere In the example shown, we have a list of email addresses, and we want to copy those that contain “abc”. In C5, the formula were using is this:


In this formula, the logical test is this bit:


This will return TRUE if the the value in B5 contains “abc” and false if not. See the cell contains specific text formula for a full explanation. To copy cell B5 if TRUE, we just need to supply B5 again for the “value if true” argument. If false, we supply an empty string ("") which will display as a blank cell on the worksheet. Author Dave Bruns Related formulas

Cell contains specific text

To check if a cell contains specific text, you can use the SEARCH function together with the ISNUMBER function. In the generic version, substring is the specific text you are looking for, and text represents text in the cell you are testing. In the…

If cell equals

If you want to do something specific when a cell equals a certain value, you can use the IF function to test the value, then do something if the result is TRUE, and (optionally) do something else if the result of the test is FALSE. If color is red,…

Cell contains one of many things

If you want to test a cell to see if it contains one of several things, you can do so with a formula that uses the SEARCH function, with help from the ISNUMBER and SUMPRODUCT functions. Context Let’s say you have a list of text strings in the range…

If cell contains one of many things To test a cell for one of several things, and return a custom result for the first match found, you can use an INDEX / MATCH formula based on the SEARCH function. In the example shown, the formula in C5 is: { = INDEX ( results , MATCH ( TRUE ,… Related functions

Paste into filtered cells

*******Paste into filterd cells*********

Sub Copy_Filtered_Cells()
     Set from = Selection
     Set too = Application.InputBox("Select range to copy selected cells to", Type:=8)
     For Each Cell In from
         For Each thing In too
             If thing.EntireRow.RowHeight > 0 Then
                 Set too = thing.Offset(1).Resize(too.Rows.Count)
                 Exit For
             End If
 End Sub


My updated version:

Sub Paste2VisRows()

Dim rFrom As Range, rTo As Range
Dim i As Long, Ofset As Long
Dim inputFrom As String
Dim inputTo As String

'inputFrom = InputBox("Select Copy Range")
rFrom = Application.InputBox("Select Copy Range", Type:=8)

'inputTo = InputBox("Select Paste Cell")
Set rTo = Application.InputBox("Select Paste Cell", Type:=8)

For i = 1 To rFrom.Rows.Count
    Do Until Not rTo.Offset(Ofset).Rows.Hidden
        Ofset = Ofset + 1
    rFrom.Rows(i).Copy Destination:=rTo.Offset(Ofset)
    Ofset = Ofset + 1
Next i

End Sub



Trim Column

Friday, August 7, 2020

Sub TrimColumnF()
  Dim Addr As String
  Addr = "F1:F" & Cells(Rows.Count, "F").End(xlUp).Row
  Range(Addr) = Evaluate("IF(" & Addr & "="""","""",TRIM(" & Addr & "))")
End Sub

Remove duplicate

Friday, August 7, 2020

Public Function Xs(rngOne, rngTwo)
    Set Xs = rngOne.Worksheet.Cells(rngOne.Row, rngTwo.Column)
End Function

Public Sub DelDup()
Dim rng As Range, Dn As Range, n As Long, Dic As Object, Txt As String, nRng As Range
Dim ws As Worksheet
Set ws = Sheets("Data")
Set rng = Range(ws.Range("A2"), ws.Range("A" & Rows.Count).End(xlUp))
Set Dic = CreateObject("scripting.dictionary")


Dic.CompareMode = vbTextCompare
For Each Dn In rng
    With Application
        Txt = Join(.Transpose(.Transpose(Dn.Resize(, 4))), ",")
    End With
    If Not Dic.Exists(Txt) Then
        Dic.Add Txt, Dn
        Dic(Txt).Offset(, 4).Value = Dic(Txt).Offset(, 4).Value + Dn.Offset(, 4).Value 'combine net amt for duplicate client
         If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, Dn)
    End If

If Not nRng Is Nothing Then nRng.EntireRow.Delete
ws.Range("E2", ws.Cells(Rows.Count, "E")).NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"


End Sub

Public Sub delmiddlename()
Dim ws As Worksheet
Dim roww As Integer
Dim outname As String
Dim inname As String

Set ws = Sheets("Data")
roww = 2

Do Until ws.Cells(roww, 1) = ""

inname = ws.Cells(roww, 6)
If UBound(Split(inname)) > 1 Then 'triggers when there's more than first and last name
    outname = splitname(inname) 'delete middle name, only show first and last name
    ws.Cells(roww, 6) = outname
End If

roww = roww + 1

End Sub

Public Function splitname(str As String)

Dim n As Integer

arr = Split(str)
n = UBound(Split(str))

splitname = arr(0) & " " & arr(n)

End Function

Public Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
    Set fldr = Nothing
End Function

Public Sub clearsheets()

'    Range("A2").Select
'    Range("A2", Cells(findlrow, "F")).Select
'    Selection.ClearContents
    Dim ws, qvws As Worksheet
    Set ws = Sheets("Data")
    Set qvws = Sheets("RESP")


End Sub

Public Function findlrow() As Long

    findlrow = Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _

End Function

Sub TrimColumn()
  Dim Addr As String
  Addr = "F1:F" & Cells(Rows.Count, "F").End(xlUp).Row
  Range(Addr) = Evaluate("IF(" & Addr & "="""","""",TRIM(" & Addr & "))")
End Sub


Wednesday, August 19, 2020

Sub RemoveHiddenRows()
    Dim oRow As Range, rng As Range
    Dim myRows As Range
    With ActiveSheet
        Set myRows = Intersect(.Range("A:A").EntireRow, .UsedRange)
        If myRows Is Nothing Then Exit Sub
    End With
For Each oRow In myRows.Columns(1).Cells
        If oRow.EntireRow.Hidden Then
            If rng Is Nothing Then
                Set rng = oRow
                Set rng = Union(rng, oRow)
            End If
        End If
If Not rng Is Nothing Then rng.EntireRow.Delete
End Sub

Get Numeric value from string

Friday, August 28, 2020

'find all number in the string
'the output is separated with comma

Function GetNineNumbers(cell As String)
Dim tStr As String
Dim regex As Object
Dim m As Object, j As Object

Set regex = CreateObject("VBScript.RegExp")
With regex
 '.pattern = "[\d-]+"
 '.pattern = "\b[\d-]+\b"
 .pattern = "-?\d*\.?\d+"
 .Global = True

 If .test(cell) Then
 Set m = .Execute(cell)
 For Each j In m
 tStr = Trim(tStr) & Trim(j) & ","
 Next j
 tStr = Left(tStr, (Len(tStr) - 1))
 'GetNineNumbers = "No matches."
 GetNineNumbers = ""
 Exit Function
 End If

End With
 GetNineNumbers = tStr

End Function
'find first number in the string

Function GetNumeric(CellRef As String)
Dim StringLength As Integer
Dim i As Long
Dim result As String

StringLength = Len(CellRef)
For i = 1 To StringLength
    If IsNumeric(Mid(CellRef, i, 1)) Then
        result = val(Mid(CellRef, i))
        Exit For
    End If
Next i
GetNumeric = result
End Function
Function GetNumbyStr(fullstr As String, str1 As String, Optional str2 As String)
Dim num As Variant
Dim val As Double

If fullstr Like "*/*" Then
num = Split(GetNineNumbers(fullstr), ",")

pos1 = WorksheetFunction.Max(InStr(1, fullstr, str1, 0), InStr(1, fullstr, str2, 0))
pos2 = InStr(1, fullstr, "/", 0)

    If pos1 = 0 Then
    GetNumbyStr = ""
    Exit Function
    End If
    If pos1 < pos2 Then 'str is infront of "/"
    GetNumbyStr = num(0)
    GetNumbyStr = num(1)    'str is in after "/"
    End If

GetNumbyStr = GetNumeric(fullstr)

End If

End Function

Get File Names in Folder

Tuesday, September 8, 2020 10:06 AM

Sub LoopThroughFiles()

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set oFolder = oFSO.GetFolder("C:\Users\Work\Testing")

For Each oFile In oFolder.Files

    Sheets("Sheet1").Cells(i + 1, 1) = oFolder & "\" & oFile.Name

    i = i + 1

Next oFile

End Sub

Merge same cells/Unmerge and duplicate down value

Monday, September 14, 2020 2:04 PM

Option Explicit

Sub Merge_Same_Cells()

Application.DisplayAlerts = False

Dim rng As Range


For Each rng In Selection

If rng.Value = rng.Offset(1, 0).Value And rng.Value <> "" Then
Range(rng, rng.Offset(1, 0)).Merge
Range(rng, rng.Offset(1, 0)).HorizontalAlignment = xlCenter
Range(rng, rng.Offset(1, 0)).VerticalAlignment = xlCenter
GoTo MergeCells
End If

End Sub
Sub UnMergeSameCell()
'Upadateby Extendoffice
Dim Rng As Range, xCell As Range
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Rng In WorkRng
    If Rng.MergeCells Then
        With Rng.MergeArea
            .Formula = Rng.Formula
        End With
    End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Floating text on UserForm

Tuesday, September 15, 2020 3:55 PM

Private Sub Label12_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Label12.ControlTipText = "description"
End Sub

Count cells

Thursday, September 17, 2020 10:05 AM

  Dim arr As Variant
  Dim countn As Long
  Dim counttotal As Long

    arr = Split(ValidateNumberUniqueness)
    countn = UBound(arr) - LBound(arr) + 1                      'count the number of "bad" cells
    counttotal = Inv.Rows.Count
    ValidateNumberUniqueness = countn & "/" & counttotal    'get the percentage of bad cells / total cells

Remove blank lines

Wednesday, September 23, 2020 2:43 PM

Public Sub RemoveBlankLines()
    Dim SourceRange As Range
    Dim EntireRow As Range

    On Error Resume Next

    Set SourceRange = Application.InputBox( _
        "Select a range:", "Delete Blank Rows", _
        Application.Selection.Address, Type:=8)

    If Not (SourceRange Is Nothing) Then
        Application.ScreenUpdating = False

        For I = SourceRange.Rows.Count To 1 Step -1
            Set EntireRow = SourceRange.Cells(I, 1).EntireRow

            If Application.WorksheetFunction.CountA(EntireRow) = 0 Then
            End If
        Application.ScreenUpdating = True
    End If
End Sub


Set search range

October 1, 2020 9:19 AM

Dim HighRiskApps As Range
  Set HighRiskApps = ThisWorkbook.Worksheets("List of High Risk Applications").UsedRange.Columns("A")

Fill blank cells with above value

December 3, 2020 1:52 PM

Sub fillme()
With Range("A2:A100")
    .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With
End Sub


Map Folder Layout

December 7, 2020 2:25 PM

Sub MakeFolders()

    Dim myLastRow As Long, myRow As Long

'   Find last row in column B
    myLastRow = Cells(Rows.Count, "A").End(xlUp).Row

'   Loop through all rows in column B starting with row 3
    For myRow = 1 To myLastRow
        If Len(Dir(ThisWorkbook.Path & "\" & Cells(myRow, "A"), vbDirectory)) = 0 Then
            On Error Resume Next
            MkDir (ThisWorkbook.Path & "\" & Cells(myRow, "A"))
            On Error GoTo 0
        End If
    Next myRow

End Sub
Sub ListFoldersInDirectory()

    Dim objFSO As Object
    Dim objFolders As Object
    Dim objFolder As Object
    Dim strDirectory As String
    Dim arrFolders() As String
    Dim FolderCount As Long
    Dim FolderIndex As Long

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Select Folder"
        If .SelectedItems.Count = 0 Then
            Exit Sub
        End If
        strDirectory = .SelectedItems(1)
    End With

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolders = objFSO.GetFolder(strDirectory).SubFolders

    FolderCount = objFolders.Count

    If FolderCount > 0 Then
        ReDim arrFolders(1 To FolderCount)
        FolderIndex = 0
        For Each objFolder In objFolders
            FolderIndex = FolderIndex + 1
            arrFolders(FolderIndex) = objFolder.Name
        Next objFolder
        Range("A1").Resize(FolderCount).Value = Application.Transpose(arrFolders)
        MsgBox "No folders found!", vbExclamation
    End If

    Set objFSO = Nothing
    Set objFolders = Nothing
    Set objFolder = Nothing

End Sub

Last Row range

January 20, 2021 4:20 PM

Rng = ws.Range("A1:C" & Cells(Rows.Count, 1).End(xlUp).Row)

Lrow =  Cells(Rows.Count, 1).End(xlUp).Row


Copy Files from Subfolders to Another Destination

February 3, 2021 4:59 PM

Public Sub CopyFiles_r3()

    Dim sPathSource As String, sPathDest As String, sFileSpec As String

    sPathSource = ActiveSheet.Cells(1, 1)  'Change to source path
    sPathDest = ActiveSheet.Cells(2, 1)      'Change to destination path

    sFileSpec = "*.xlsm"                                 'file extension, use "*.*" if copy all files
    'sFileSpec = "*example*2020.xl*"
    'sFileSpec = "*.pdf"

    Call CopyFiles_FromFolderAndSubFolders(sFileSpec, sPathSource, sPathDest)
End Sub

Public Sub CopyFiles_FromFolderAndSubFolders(ByVal argFileSpec As String, ByVal argSourcePath As String, ByRef argDestinationPath As String)

    Dim sPathSource As String, sPathDest As String, sFileSpec As String

    Dim FSO         As Object
    Dim oRoot       As Object
    Dim oFile       As Object
    Dim oFolder     As Object

    sPathSource = argSourcePath
    sPathDest = argDestinationPath

    If Not Right(sPathDest, 1) = "\" Then sPathDest = sPathDest & "\"
    If Right(sPathSource, 1) = "\" Then sPathSource = Left(sPathSource, Len(sPathSource) - 1)

    Set FSO = CreateObject("Scripting.FileSystemObject")

    If FSO.FolderExists(sPathSource) And FSO.FolderExists(sPathDest) Then
        Set oRoot = FSO.GetFolder(sPathSource)
        For Each oFile In oRoot.Files
            If LCase(oFile.Name) Like argFileSpec Then
                On Error Resume Next
                oFile.Copy sPathDest & oFile.Name
                On Error GoTo 0
            End If
        Next oFile

        For Each oFolder In oRoot.SubFolders
            ' == do the same for any folder ==
            Call CopyFiles_FromFolderAndSubFolders(argFileSpec, oFolder.Path, sPathDest)
        Next oFolder
    End If

End Sub

Set Outlook Schedule

May 18, 2021 10:50 AM

olBusy 2 The user is busy. olFree 0 The user is available. olOutOfOffice 3 The user is out of office. olTentative 1 The user has a tentative appointment scheduled. olWorkingElsewhere 4 The user is working in a location away from the office.


Sub ScheduleHoliday()
Dim olApp As Outlook.Application

Dim es As Worksheet
Set es = ActiveSheet

Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If

Dim myStart, myEnd

For r = 1 To es.Cells(Rows.Count, 1).End(xlUp).Row
Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
    With olAppItem
          .Subject = Cells(r, 2).Value
          .AllDayEvent = True
          .Start = DateValue(Cells(r, 1).Value) + TimeSerial(0, 0, 0)
          .End = DateValue(Cells(r, 1).Value) + 1 + TimeSerial(0, 0, 0)
          .BusyStatus = olOutOfOffice 'set status as out of office
  '        .Display (True)
      End With
Next r

End Sub

Sub ScheduleAppointment()
Dim olApp As Outlook.Application

Dim es As Worksheet
Set es = Worksheets("Sheet1")

Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If

Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
Dim myStart, myEnd

For r = 3 To 21
With olAppItem
        .Subject = Cells(r, 2).Value
        myStart = DateValue(Cells(r, 1).Value) + Cells(r, 3).Value
        myEnd = DateValue(Cells(r, 1).Value) + Cells(r, 4).Value
        .Start = myStart
        .End = myEnd
    End With
Next r

End Sub

Quick filters using one or multiple criteria

June 22, 2021 11:18 AM

Filter on one column:

Sub filter()
Dim data As String

data = InputBox("Enter filter value")

ActiveSheet.Range("$A$1:$AR$33140").AutoFilter Field:=30, Criteria1:=data

End Sub

Sub clear()

On Error Resume Next
If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData

End Sub

 Filter on multiple columns:
Filter multiple values (OR condition)

Selection.AutoFilter field:=10, Operator:=xlFilterValues, Criteria1:=Array("x", "y", "z")