VBA – Display a File Open Dialog Box For the User to Select a File – Excel functions

/in , , /by

Below is a demonstration of using Application.FileDialog to give the user an option to select a file. The code is well commented and should be self explanatory.

The full file path will be stored in fullpath variable, which can be used later in the code.

An example using the code to prompt the user to select an Excel file an open it in Excel can be found here http://www.chicagocomputerclasses.com/excel-vba-display-a-file-open-dialog-and-open-the-file-excel-functions/

Sub FileOpenDialogBox()

'Display a Dialog Box that allows to select a single file.
'The path for the file picked will be stored in fullpath variable
  With Application.FileDialog(msoFileDialogFilePicker)
        'Makes sure the user can select only one file
        .AllowMultiSelect = False
        'Filter to just the following types of files to narrow down selection options
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
        'Show the dialog box
        .Show
        
        'Store in fullpath variable
        fullpath = .SelectedItems.Item(1)
    End With

End Sub

 

Posted by Excel Instructor:

http://www.chicagocomputerclasses.com/excel-classes/

Excel VBA Function to SUM Unique Numbers Only – Unique SUMIF Function

/in , , /by

First add this code to your VBA Function

 

Function SUMIFUNIQUENUMS(rng2 As Range, rng1 As Range, rng3 As Range)

    num = rng1.Count - 1
    Dim arr1() As Variant
    ReDim arr1(num)
    i = 0
    For Each r In rng1
    
        If r.Value = rng3.Value Then
            arr1(i) = 1 * rng2(i + 1)
        Else
            arr1(i) = 0
        End If
        i = i + 1
        
    Next r
    
    Dim arr As New Collection, a
    
    On Error Resume Next
    
      For Each a In arr1
         arr.Add a, Str(a)
      Next
    
    
      insum = 0
      
        For Each n In arr
            insum = insum + n
        Next n
        
        SUMIFUNIQUENUMS = insum

End Function

 

Then use it in your worksheet like this

A B C D E
1 CA 11 CA =SUMIFUNIQUENUMS($B$1:$B$7,$A$1:$A$7,D1)
2 NY 14 NY 29
3 NY 15 IN 0
4 CA 11
5 CA 11
6 CA 14
7 CA 11
Sheet1

 

Posted by Excel Instructor:
http://www.chicagocomputerclasses.com/excel-classes/

VBA – Check Regular & Overtime Hours – Excel functions

/in , , /by

Below are 2 Excel VBA UDFs to check and divide regular and overtime hours based on 40 hour week, Monday through Friday Payroll.

Date Hours Worked Regular Overtime
12/15/15 14 14 0
12/16/15 9 9 0
12/17/15 11 11 0
12/18/15 9 6 3
12/19/15 7 0 7
12/20/15 8 0 8
12/21/15 5 5 0
12/22/15 2 2 0
12/23/15 1 1 0
12/24/15 1 1 0
12/25/15 6 6 0
12/26/15 7 7 0
12/27/15 14 14 0
12/28/15 9 9 0
12/29/15 9 9 0
12/30/15 9 9 0
12/31/15 9 9 0
1/1/16 8 4 4
1/2/16 9 0 9
1/3/16 13 0 13
1/4/16 15 15 0
1/5/16 10 10 0 
Public Function REG(datecol As Range, hourscol As Range)
hrs = 0
For i = 2 To datecol.Row

   dt = Application.WeekNum(Cells(i, datecol.Column), 2)
   cdt = Application.WeekNum(Cells(datecol.Row, datecol.Column), 2)

   If dt = 53 Then
    dt = 1
   End If
   If cdt = 53 Then
    cdt = 1
   End If

   If cdt = dt Then
        hrs = hrs + Cells(i, hourscol.Column).Value

   End If

   If hrs <= 40 Then         REG = Cells(datecol.Row, hourscol.Column)    Else         If (40 - (hrs - Cells(datecol.Row, hourscol.Column))) > 0 Then
            REG = 40 - (hrs - Cells(datecol.Row, hourscol.Column))
        Else
            REG = 0
        End If
   End If
Next i

End Function

Public Function OVT(datecol As Range, hourscol As Range)
hrs = 0
For i = 2 To datecol.Row

   dt = Application.WeekNum(Cells(i, datecol.Column), 2)
   cdt = Application.WeekNum(Cells(datecol.Row, datecol.Column), 2)

   If dt = 53 Then
    dt = 1
   End If
   If cdt = 53 Then
    cdt = 1
   End If

   If cdt = dt Then
        hrs = hrs + Cells(i, hourscol.Column).Value

   End If

   If hrs > 40 Then
        If (hrs - Cells(datecol.Row, hourscol.Column)) > 40 Then
            OVT = Cells(datecol.Row, hourscol.Column)
        Else
         OVT = hrs - 40
        End If
   Else

    OVT = 0
   End If
Next i

End Function

Posted by Excel Instructor:
http://www.chicagocomputerclasses.com/excel-classes/

VBA – Unique List of Data That Appears At Least Once in All Columns – Excel Macro

/in , , /by

Use this VBA code to extract a unique list of items that appear inside of multi-column data. The criteria is that the data needs to appear at least once in each column. This one has user friendly interface to run on any size data and get the results wherever user picks in the worksheet.

Sub UniqueListMatchingMultipleColumns()

Dim rng As Range
Dim srcrng As Range

Set rng = Range("g1")

Set srcrng = Application.InputBox("Please select you data (Do not include column headings!)", , , Type:=8)
Set rng = Application.InputBox("Click the cell where you'd like the output to start rendering (a single cell):", , Type:=8)

longstr = "||||"
finalstring = "||||"
For Each i In srcrng

If InStr(longstr, "||||" & i.Value & "||||") = 0 Then

    longstr = longstr & i.Value & "||||"
End If

Next i

For Each word In Split(Mid(longstr, 5, Len(longstr) - 8), "||||")
    n = 1
    got = 0
    For Each col In srcrng.Columns
        mt = Application.Match(word, srcrng.Columns(n), 0)
        If IsNumeric(mt) Then
            got = 1
        Else

            got = 0
            Exit For
        End If

        n = n + 1
    Next col

    If got = 1 Then
        finalstring = finalstring & word & "||||"

    End If

Next word
r = 0
For Each finalword In Split(Mid(finalstring, 5, Len(longstr) - 8), "||||")
    rng.Offset(r, 0).Value = finalword
    r = r + 1
Next finalword

End Sub

Posted by Excel Instructor:
http://www.chicagocomputerclasses.com/excel-classes/

VBA – Loop Through All Textboxes in a Form – Excel Macro

/in , , /by

This VBA code will loop though all textboxes in your userform that are following the naming convention textBox[x] (ex. textBox1, textBox2, textBox3 ….. textBox255)

For Each txtboxitem In Me.Controls
    If Left(txtboxitem.Name, 6) = "textBox" Then
        If txtboxitem.Text <> "" Then

                'do something

            Exit For
        End If
    End If
Next txtboxitem

Posted by Excel Instructor:
http://www.chicagocomputerclasses.com/excel-classes/

VBA – Loop Through All (.txt) Files in a User Specified Directory – Excel Macro

/in , , /by

This VBA code will loop though all the text files in a directory that user picks from an application box and print a list of them. This code can be modified to be used in many scenarios for any file type.

 

Sub LoopThroughAllTextFilesInFolder()

    'Declarations
        Dim wb As Workbook
        Dim DirPath As String
        Dim FileName As String
        Dim FileExt As String
        Dim UserFolderChoice As FileDialog
        Dim i As Integer
        Dim howmany As Integer
    'Declarations End

    'Regular Stuff
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.Calculation = xlCalculationManual
    'Regular Stuff End

    'User's Folder Choice
        Set UserFolderChoice = Application.FileDialog(msoFileDialogFolderPicker)

        With UserFolderChoice
          .Title = "Select A Target Folder"
          .AllowMultiSelect = False
            If .Show <> -1 Then GoTo AllGood
            DirPath = .SelectedItems(1) & "\"
        End With
    'User's Folder Choice End

AllGood:

    'Check if path is empty
      If DirPath = "" Then GoTo JumpToEnd

    'File Extension
      FileExt = "*.txt"

    'Let's find the first file & how many total files we have
      FileName = Dir(DirPath & FileExt)
      howmany = Len(Dir(DirPath & FileExt))

        'let's loop though them
            For i = 1 To howmany

                'print the name of the file
                Debug.Print FileName

                'move to the next file
                FileName = Dir
            Next i

'Done!!!

JumpToEnd:

    'Regular Stuff
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    'Regular Stuff End

End Sub

Posted by Excel Instructor:
http://www.chicagocomputerclasses.com/excel-classes/

VBA – Get Information From a Web Page – Excel Macro – Amazon Example

/in , , /by

This is a basic VBA code to get started with InternetExplorer.Application object and work with web browsers and data extraction. This code is written strictly for learning proposes and should be used as such. Everything is well commenced out so it should be really easy to understand. In this example we use Internet Explorer to open a product page on Amazon and we extract the page title & product price and add the data to our spreadsheet.

 

Sub Basics_Of_Web_Macro()

    Dim myIE As Object
    Dim myIEDoc As Object

    'Start Internet Explorer
    Set myIE = CreateObject("InternetExplorer.Application")

    'if you want to see the window set this to True
    myIE.Visible = False

    'Now we open the page we'd like to use as a source for information
    myIE.Navigate "http://www.amazon.com/gp/product/B00J34YO92/ref=s9_ri_gw_g421_i1?pf_rd_m=ATVPDKIKX0DER&pf_rd_s=desktop-3&pf_rd_r=090F56JZ7KPTB48JWMDW&pf_rd_t=36701&pf_rd_p=2090151042&pf_rd_i=desktop"

    'We wait for the Explorer to actually open the page and finish loading    
    While myIE.Busy
        DoEvents
    Wend

    'Now lets read the HTML content of the page        
    Set myIEDoc = myIE.Document

    'Time to grab the information we want            

        'We'll start with the Title of the page        
        Range("A1") = myIEDoc.Title
        'Then we'll get something from teh inner page content by using the ID        
        Range("B1") = myIEDoc.getElementById("priceblock_ourprice").innerText

End Sub

Posted by Excel Instructor:
http://www.chicagocomputerclasses.com/excel-classes/

VBA – Get All Numbers in a Text String & Incresae by One – Excel Macro

/in , , /by

The following procedure will take any numbers within text and increase them by 1.

For Example:
For20Example51Text will transform into For21Example52Text

 

Sub UpNumbersByOne()

cell = "YOUR16STRING1HERE10"

Dim v As Variant
 endresult = ""

With CreateObject("VBScript.RegExp")
    .Pattern = "(\d+|\D+)"
    .Global = True
        v = Split(Mid(.Replace(cell, "|$1"), 2), "|")
        For Each num In v
        If IsNumeric(num) = True Then
        num = num + 1
        End If
        endresult = endresult & num
        Next num
End With

Debug.Print endresult

End Sub

Posted by Excel Instructor:
http://www.chicagocomputerclasses.com/excel-classes/

VBA – Get First Number & Then Text & Following Number – Excel Macro

/in , , /by

This Excel Macro will transform the text data placed in column A and Break it down into 3 Columns.

Data Format Required:
15654 Text goes Here 16 2 6 1595
1 Different Text 1 6
number (space) text of any lenght (space) number (space) other characters

Output will return:

  1. First column: full first number
  2. Second column: full text string in the middle of surrounded numbers
  3. Third Column: first full number after text
Sub BreakTextNum()
lr = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
    For Each cell In Range("a1:a" & lr)

    'grab teh number
    num = Left(cell, InStr(cell, " ") - 1)

    'grab teh text
        For i = 1 To Len(cell)
            Dim currentCharacter As String
            currentCharacter = Mid(cell, InStr(cell, " ") + i, 1)
            If IsNumeric(currentCharacter) = True Then
                GetPositionOfFirstNumericCharacter = i
                Exit For
            End If
        Next i

    txt = Mid(cell, InStr(cell, " ") + 1, i - 2)
    'grab teh after number
    lasti = i + InStr(cell, " ") - 2
    anum = Mid(cell, lasti + 2, InStr(lasti + 2, cell, " ") - lasti - 2)

    Cells(cell.Row, 2) = num
    Cells(cell.Row, 3) = txt
    Cells(cell.Row, 4) = anum

    Next cell

End Sub

Posted by Excel Instructor:
http://www.chicagocomputerclasses.com/excel-classes/

VBA – Delete Every Other Row – Odd or Even – Excel Macro

/in , , /by

This Excel Macro will go through all the cells in column A, find the last cell that has data in it, and then delete every other row in that data range.

To Delete Odd Rows

Sub Delete_Odd()

 Application.ScreenUpdating = False
lr = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

If lr Mod 2 = 0 Then
lr = lr - 1
End If

For i = lr To 1 Step -2
    Rows(i & ":" & i).Delete Shift:=xlUp    
Next i

 Application.ScreenUpdating = True

End Sub

To Delete Even Rows

Sub Delete_Even()

 Application.ScreenUpdating = False
lr = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

If lr Mod 2 = 0 Then
Else
lr = lr - 1
End If

For i = lr To 1 Step -2
    Rows(i & ":" & i).Delete Shift:=xlUp    
Next i

  Application.ScreenUpdating = True

End Sub

Posted by Excel Instructor:
http://www.chicagocomputerclasses.com/excel-classes/