Excel-User.com

VLOOKUP() function only returns values from the columns to the left of the key field. You can’t build the formula and give it a column index number of –1, for instance. This is will result on a #VALUE error, like on the following example:

On this example, we want to retrieve the value on the Date column that matches with the ID on cell B14 so we putted a –1 column index number on the function that didn’t worked.
A simple way of going around this problem is to build our own VLOOKUPNEG (as from negative) function that works with negative column index numbers and can return values to the left of the key field, in this case, the Date value that is on the left of the ID column. So, this is the UDF (User Defined Function) that you can create:

Function VLOOKUPNEG(lookup_value, table_array As Range, col_index_num As Integer, CloseMatch As Boolean)

Dim RowNr As Long

RowNr = Application.WorksheetFunction.Match(lookup_value, table_array.Resize(, 1), CloseMatch)
VLOOKUPNEG = table_array(RowNr, 1).Offset(0, col_index_num)

End Function

Using this UDF, on the same example, we will get this result:

Now, on cell B15, we are already getting the Date that matches the 1002 ID that was on cell B14: 14-05-11!

This is a common problem that many users have: they got a list of data, that has some blank cells in the middle, and they want to fill the blanks with the value from the last cell above. Here’s an example on how your sheet could look like:

As you can see, we have some blank cells that we need to fill with the value from the last filled row above on the Company and Country columns. We would like to obtain this:

For that, we can use this code:

Sub FillSelectionBlanksBelow()
    Dim Cell As Range
    For Each Cell In Selection
        If Cell.Value = "" Then Cell.Value = Cell.Offset(-1, 0).Value
    Next Cell
End Sub

Then you just need to select the range where you want to apply it (in this case A2:D11) and run the macro and you will get the blanks cells filled down.

This is a simple code that is very useful if you want to change the font size on all comments that you have on your Excel sheet.

Sub ChangeCommentsFont()
    Dim cmt As Comment
    For Each cmt In ActiveSheet.Comments
        With cmt.Shape.TextFrame.Characters.Font
            .Size = 11
        End With
    Next cmt
End Sub

You can change this code for setting a new font name, font color, etc.

This is a simple thing that sometimes we need to use. We have an Excel sheet that has a list of, for example, names in column A and we want to create folders for each of them on a disk. For that we can make a small VBA code to go through each of the rows on column A and create a folder with that name on the path that we specify on our code. To do that, I came up with this code:

Sub MakeFolders()
    Dim xdir As String
    Dim fso
    Dim lstrow As Long
    Dim i As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 1 To lstrow
        'change the path on the next line where you want to create the folders
        xdir = "C:\" & Range("A" & i).Value
        If Not fso.FolderExists(xdir) Then
            fso.CreateFolder (xdir)
        End If
    Next
    Application.ScreenUpdating = True
End Sub

On this example, I will create the folders under C:\ If you want a different place, just change it on the code.

This code is used to put borders around every used cell on a sheet.

Sub DrawBorders()
   With Cells.SpecialCells(xlCellTypeConstants, 23)
       .BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
        On Error Resume Next 'used in case there are no inside borders
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    End With
End Sub

If you want to put Autofilter on all of the sheets on a workbook, you can't do it by select all of the sheets on the sheets tabs. Instead you can use this simple VBA code:

Sub Autofilterall()

    Dim ws As Worksheet
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        ws.Activate
        Range("A1").Activate
        Selection.AutoFilter
    Next ws
    Application.ScreenUpdating = True

End Sub

Sub GetSheetNames_andRowCounts()

    Dim i As Integer
    Dim j As Integer
    Dim SheetCnt As Integer
    Dim lstRow As Long
    Dim ws1 As Worksheet
    Dim SheetName As String
    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    On Error Resume Next
    'Delete the Target Sheet on the document (in case it exists)
    Sheets("Target").Delete
    SheetCnt = Worksheets.Count
    'Add the Target Sheet
    Sheets.Add after:=Worksheets(SheetCnt)
    ActiveSheet.Name = "Target"
    Set ws1 = Worksheets("Target")
    j = 1
    'Combine the sheets
    For i = 1 To SheetCnt
        Worksheets(i).Select
        'check what is the last row with data using column A as a reference
        lstRow = ActiveSheet.Cells(65536, "A").End(xlUp).Row
        'get the name of the sheet
        SheetName = Worksheets(i).Name
        'assign the values to the Target sheet
        ws1.Cells(j, 1).Value = SheetName
        ws1.Cells(j, 2).Value = lstRow1
        j = j + 1
    Next
    With Application
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Sheets("Target").Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select

End Sub

For this, I have the following code:

Sub InsertPictures()
    Dim cll As Range
    Dim rng As Range
    Dim strPath As String
    strPath = "D:\Photo Folder"
    With Sheets("Sheet1")
        Set rng = Range("A2:A416")
    End With
    For Each cll In rng
        If Dir$(strPath & "\" & cll.Value & ".jpg") <> "" Then
            With cll
                .ClearComments
                .AddComment ("")
                .Comment.Shape.Fill.UserPicture (strPath & "\" & cll.Value & ".jpg")
                .Comment.Shape.Height = 160
                .Comment.Shape.Width = 120
                .Comment.Shape.LockAspectRatio = msoTrue
                End With
        End If
    Next cll
End Sub
You can adjust the size of your photos by changing the Height (160) and Width (120).

In VBA code we can define a dynamic range by checking the last row that has data on it. this can be defined in various ways. Here is a simple way of doing it:

Dim rng As Range
rng = Range("A12:C" & Worksheets("Sheet1").Range("C65535").End(xlUp).Row + 1)

This will get us the range A12:C200 if C200 is the last used cell in column C.
You can also define a range that gets all of the columns in row 1 that are used as column headers, like this:

Dim ws As Worksheet
Dim rng As RangeSet
ws = ActiveSheetSet
rng = Intersect(ws.Rows(1), ws.UsedRange)

This will get us the range of A1:D4 if columns A, B, C and D have data on it.

When we have colors on our sheets data and want, for instance, to count how many “red” words we have on our sheet, that is not possible because there is no formula in Excel to check for font colors. Instead we can create our own VBA Function to get the font color. It’s a very simple code. You have to insert it on a VBA module on your sheet.

Function GetFontColor(ByVal Target As Range) As Object
    GetFontColor = Target.Font.ColorIndex
End Function

Then you can use it on your sheet like this:

GETFONTCOLOR(A2)

Below is an example on how you can use this function. In column C we put the font color of text in column A.

To count the number of “red” words in column A we can simple to this:

COUNTIF(C2:C9,3)

“3” in the formula refers to the color red.

I have a Workbook with multiple sheets, all with the same configuration, with headers on row 1 and data starting from row 2.
I want to combine the data from all the sheets into one single sheet called “Target”. I have to go through all the sheets and check what is the last row and the last column with data to define the range that I’m going to copy to the Target sheet. I think that the code is all well commented for you to understand how this is done. This is a simple example how to combine data from multiple sheets into one single sheet. This can be done other ways or can be more complex with sheets with different columns or so. This will be handled in future articles.

Sub CombineSheets()



'This macro will copy all rows from the first sheet


'(including headers)


'and on the next sheets will copy only the data


'(starting on row 2)



Dim i As Integer


Dim j As Long


Dim SheetCnt As Integer


Dim lstRow1 As Long


Dim lstRow2 As Long


Dim lstCol As Integer


Dim ws1 As Worksheet



With Application


.DisplayAlerts = False


.EnableEvents = False


.ScreenUpdating = False


End With



On Error Resume Next



'Delete the Target Sheet on the document (in case it exists)


Sheets("Target").Delete


'Count the number of sheets on the Workbook


SheetCnt = Worksheets.Count



'Add the Target Sheet


Sheets.Add after:=Worksheets(SheetCnt)


ActiveSheet.Name = "Target"


Set ws1 = Sheets("Target")


lstRow2 = 1


'Define the row where to start copying


'(first sheet will be row 1 to include headers)


j = 1



'Combine the sheets


For i = 1 To SheetCnt


Worksheets(i).Select



'check what is the last column with data


lstCol = ActiveSheet.Cells(1, Activesheet.Columns.Count).End(xlToLeft).Column



'check what is the last row with data


lstRow1 = ActiveSheet.Cells(activesheet.rows.count, "A").End(xlUp).Row



'Define the range to copy


Range("A" & j, Cells(lstRow1, lstCol)).Select



'Copy the data


Selection.Copy


ws1.Range("A" & lstRow2).PasteSpecial


Application.CutCopyMode = False



'Define the new last row on the Target sheet


lstRow2 = ws1.Cells(65536, "A").End(xlUp).Row + 1



'Define the row where to start copying


'(2nd sheet onwards will be row 2 to only get data)


j = 2


Next



With Application


.DisplayAlerts = True


.EnableEvents = True


.ScreenUpdating = True


End With



Sheets("Target").Select


Cells.EntireColumn.AutoFit


Range("A1").Select



End Sub

On a sheet column I have email addresses and I want to convert them to hyperlinks so that when I click them, I open my email client and send and email to that address. I can use a macro to change the content of that cell to a hyperlink. Here’s the code for that:

Sub Convert_to_Hyperlink()

    Dim rng As Range
    Dim cell As Range

    'Define here the range where you have your emails values
    rng = Range("B2:B100")

    For Each cell In rng
        'If the cell is blank, ignore it
        If cell.Value <> "" Then
            cell.Hyperlinks.Add ANCHOR:=cell, Address:="mailto:" & cell.Value, TextToDisplay:=cell.Value
        End If
    Next cell

End Sub

One of the most common questions I get is how to delete rows based on one or more conditions. For instance, you want to delete all rows in your sheets that have the name “John” in column A. Here’s the code to do that:

Sub Delete()

    Dim startrow As Long
    'starting row number here
    startrow = 1
    ' Assuming data to check is in A Column
    Do Until startrow > Cells(Cells.Rows.Count, "A").End(xlUp).Row
        If Cells(startrow, 1).Value = "John" Then
            Rows(startrow).Delete
        Else
            startrow = startrow + 1
        End If
    Loop

End Sub

If you want to copy all of your worksheets from the actual workbook to another workbook, you can use this simple VBA code to do it.

Sub copy_sheets()

    Dim wb1 As Workbook
    Dim wb2 As Workbook
    wb1 = ActiveWorkbook
    'Change the name of the destination workbook here
    wb2 = Workbooks("Destination.xls")
    For Each Sheet In wb1.Sheets
        If Sheet.Visible = True Then
            'copy the sheets after the last
            'sheet of the destination workbook
            Sheet.Copy After:=wb2.Sheets(wb2.Sheets.Count)
        End If
    Next Sheet

End Sub

I’ve written this code for a user that wanted to change a value in hundreds of Excel files that where in several sub folders under a main folder. This code will go through the main folder C:\Test and will replace the value on cell A1 on Sheet1 of every Excel file it will find. You can adapt this code by changing the folder name, cell destination or sheet name.

Sub Change_Value_On_Files()

    Dim fso, folder, files, NewsFile, sFolderSet
    objExcel = CreateObject("Excel.Application")
    objExcel.Visible = TrueSet
    fso = CreateObject("Scripting.FileSystemObject")
    sFolder = "C:\Test"
    Set folder = fso.GetFolder(sFolder)
    Set files = folder.files
    For Each SubFolder In folder.SubFolders
        For Each folderIdx In SubFolder.files
            If Right(folderIdx, 4) = ".xls" Then
                Set objWorkbook = objExcel.Workbooks.Open(folderIdx)
                Set objWorksheet = objWorkbook.Worksheets(1)
                Set objRange = objWorksheet.Range("A1")
                objRange.Range("A1").Value = "YOUR VALUE HERE!"
                objWorkbook.Save
                objWorkbook.Close True
            End If
        Next
    Next

End Sub