🪴 Aster's notebook

Search

SearchSearch

VBA

Aug 22, 2022, 13 min read

Link:

Today’s Date

Covert today’s date to text

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

https://social.msdn.microsoft.com/Forums/en-US/a1e66a3d-de0f-4a10-8668-f1b5dd88f3eb/convert-todays-date-to-text-using-vba?forum=exceldev

Print web page

'print ticket
        TimeOutWebQuery = 5
        TimeOutTime = DateAdd("s", TimeOutWebQuery, Now)
        Do Until appIE.readyState = 4
        DoEvents
        If Now > TimeOutTime Then
            appIE.stop
            GoTo ErrorTimeOut
        End If
        Loop
        appIE.ExecWB 6, 2
        Application.Wait (Now + TimeValue("0:00:03"))
ErrorTimeOut:
        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

PDF

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(ISNUMBER(SEARCH("abc",A1)),A1,"")

Explanation

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:

=IF(ISNUMBER(SEARCH(“abc”,B5)),B5,"")

In this formula, the logical test is this bit:

ISNUMBER(SEARCH(“abc”,B5))

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
         Cell.Copy
         For Each thing In too
             If thing.EntireRow.RowHeight > 0 Then
                 thing.PasteSpecial
                 Set too = thing.Offset(1).Resize(too.Rows.Count)
                 Exit For
             End If
         Next
     Next
 End Sub

From https://superuser.com/questions/472672/paste-a-range-into-a-filtered-table

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
    Loop
    rFrom.Rows(i).Copy Destination:=rTo.Offset(Ofset)
    Ofset = Ofset + 1
Next i

End Sub

Lookup

=IFERROR(VLOOKUP(A2,Sheet1!B3000,7,FALSE),“N/A”)

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")

TrimColumn

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
    Else
        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
Next

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

delmiddlename


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

Nextacct:
roww = roww + 1
Loop

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
NextCode:
    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")

    qvws.Range("A2:J200").ClearContents
    ws.Range("A2:J200").ClearContents

End Sub

Public Function findlrow() As Long

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

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

RemoveHiddenRows

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
            Else
                Set rng = Union(rng, oRow)
            End If
        End If
    Next
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))
 Else
 '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)
    Else
    GetNumbyStr = num(1)    'str is in after "/"
    End If

Else
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

MergeCells:

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
Next


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
            .UnMerge
            .Formula = Rng.Formula
        End With
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

From https://www.extendoffice.com/documents/excel/1139-excel-unmerge-cells-and-fill.html

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
                EntireRow.Delete
            End If
        Next
        Application.ScreenUpdating = True
    End If
End Sub

From https://www.ablebits.com/office-addins-blog/2018/12/19/delete-blank-lines-excel/

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

From https://www.mrexcel.com/board/threads/vba-fill-blank-cells-with-above-value.953768/

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"
        .Show
        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
        Worksheets.Add
        Range("A1").Resize(FolderCount).Value = Application.Transpose(arrFolders)
    Else
        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

From https://www.excelcampus.com/vba/find-last-row-column-cell/

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.

From https://docs.microsoft.com/en-us/office/vba/api/outlook.olbusystatus

Sub ScheduleHoliday()
'
Dim olApp As Outlook.Application

Worksheets("Holiday").Activate
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)
          .Save
      End With
Next r

End Sub


Sub ScheduleAppointment()
'
Dim olApp As Outlook.Application



Worksheets("Sheet1").Activate
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
        .Save
    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")

From https://stackoverflow.com/questions/50721630/vba-autofilter-using-multiple-criteria

Graph View

Backlinks

  • No backlinks found