Review Code for Efficiency

[BenChod]

HI -

I am hoping that one of the Excel/VBA experts can take a look at my code and recommend how to make it more efficient. The code is doing a vlookup and pasting the results into two columns: Column 1 and last column in the range. I am using a last row and col functions (not copied) to paste the results instead of using a fixed range because the rows and columns will change. I do have one question: is it possible to use last row / col in instead of a range for the following lines: table1 = sh.Range("Y2:y5000") table2 = sh1.Range("A2:C22")?

Sub vlookup3()
On Error Resume Next
Dim Dept_Row As Long
Dim Dept_Clm As Long
Dim Dept_Row1 As Long
Dim Dept_Clm1 As Long
Dim sh As Worksheet
Dim sh1 As Worksheet
Dim lc As Long
Dim lr As Long
Dim lc1 As Long
Dim lr1 As Long

With Worksheets("QC")
        .Columns(1).Insert
        .Cells(1) = "Env"
End With

Set sh = Sheets("QC")
Set sh1 = Sheets("ReferenceData")
lc = LastCol(sh)
lr = Lastrow(sh)
lc1 = LastCol(sh1)
lr1 = Lastrow(sh1)

sh.Cells(lc + 1).Value = "Testing Stream"

table1 = sh.Range("Y2:y5000")
table2 = sh1.Range("A2:C22")

Dept_Row = sh.Range("A2").Row
Dept_Clm = sh.Range("A2").Column
Dept_Row1 = sh.Cells(2, lc + 1).Row
Dept_Clm1 = sh.Cells(lc + 1).Column

For Each cl In table1
  sh.Cells(Dept_Row, Dept_Clm) = Application.WorksheetFunction.VLookUp(cl, table2, 2, False)
  sh.Cells(Dept_Row1, Dept_Clm1) = Application.WorksheetFunction.VLookUp(cl, table2, 3, False)
  Dept_Row = Dept_Row + 1
  Dept_Row1 = Dept_Row1 + 1
Next cl

'MsgBox "Done"
End Sub

[SamT]

I tbhimk this ill work

Option Explicit

Sub vlookup3()
    Dim QC As Worksheet
    Dim RefDat As Worksheet
    Dim QCTable As Range
    Dim RefTable As Range
    Dim Dept_Clm As Range
    Dim TestCol As Range
    
    Dim WSF As Object
    Dim Cel As Range
     
    Set QC = Sheets("QC")
    Set RefDat = Sheets("ReferenceData")
    Set WSF = Application.WorksheetFunction
    
    With QC
       .Columns(1).Insert
        Set Dept_Clm = .Columns(1)
        'Use last non empty column plus 1
        Set TestCol = .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Column
        Dept_Clm.Cells(1) = "Env"
        TestCol.Cells(1).Value = "Testing Stream"
       'Use bottom non empty cell in "Y"
        Set QCTable = QC.Range(.Cells(2, "Y"), .Cells(Rows.Count, "Y").End(xlUp))
    End With 'QC
     
    With RefDat
      'Use bottom non empty cell in "C"
      Set RefTable = .Range(.Cells(2, "A"), .Cells(Rows.Count, "C").End(xlUp))
    End With 'RefDat
    
      For Each Cel In QCTable
        On Error GoTo NotFound
        Dept_Clm.Cells(Cel.Row) = WSF.VLookup(Cel, RefTable, 2, False)
        TestCol.Cells(Cel.Row) = WSF.VLookup(Cel, RefTable, 3, False)
        GoTo Continue 'No errors
        
NotFound:
        Dept_Clm.Cells(Cel.Row) = Cel.Value & "Not Found"
        On Error GoTo 0 'Resets error handling
Continue:
      Next Cel
     
     'MsgBox "Done"
End Sub

[BenChod]

Thank you for taking a look at my code. I ran your code and I received an 'Object Required' error at this line in your code: Set TestCol = .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Column.

[SamT]

Change ".Column" to ".EntireColumn"



".Column" is a column number
".EntireColumn" is a Range Object


Cells(RowNumber, ColumnNumber, or letter)
.Cells(Rows.Count, "C").End(xlUp))
Rows.Count is also the number of the bottom Row on the sheet
".End(xlUp)" is like pressing Ctrl+Up Arrow key
It is as if .End was the Ctrl Key and (xlUp), the Up arrow, (xlDown) the Down arrow, (xlToLeft) and (xlToRight), the left and right arrows.

[BenChod]

Thank you for looking at my code and the explanations. Your code worked perfectly. Another question, is it effective to use a function to find the last row / col? Or is it better to write out the code every time?

[SamT]

IMO, it's personal Preference.

Generally, Last Row is sheet and column specific

However there is Real Last Row code that return the actual last non empty Row and Column on a sheet

;Stub exracted from: http://www.vbaexpress.com/kb/getarticle.php?kb_id=83
             'Find the last used cell with a formula and value
             'Search by Columns and Rows
            On Error Resume Next
            Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
            Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
            Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            On Error GoTo 0
             
             'Determine the last column
            If ColFormula Is Nothing Then
                LastCol = 0
            Else
                LastCol = ColFormula.Column
            End If
            If Not ColValue Is Nothing Then
                LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
            End If
             
             'Determine the last row
            If RowFormula Is Nothing Then
                LastRow = 0
            Else
                LastRow = RowFormula.Row
            End If
            If Not RowValue Is Nothing Then
                LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
            End If
             
             'Determine if any shapes are beyond the last row and last column
            For Each Shp In .Shapes
                j = 0
                k = 0
                On Error Resume Next
                j = Shp.TopLeftCell.Row
                k = Shp.TopLeftCell.Column
                On Error GoTo 0
                If j > 0 And k > 0 Then
                    Do Until .Cells(j, k).Top > Shp.Top + Shp.Height
                        j = j + 1
                    Loop
                    If j > LastRow Then
                        LastRow = j
                    End If
                    Do Until .Cells(j, k).Left > Shp.Left + Shp.Width
                        k = k + 1
                    Loop
                    If k > LastCol Then
                        LastCol = k
                    End If
                End If
            Next

[BenChod]

That is one long piece of code to find the last row/col

[Paul_Hossler]

That is one long piece of code to find the last row/col

Yes, but I put it in a function in my tool kit so I can just reuse it

I did have to make two changes since it seemed to give me an extra row and column if there was a shape like the picture below w/o the 2 changes


Capture.JPG

Option Explicit
Sub test()
    MsgBox RealLastUsed(ActiveSheet).Address
End Sub
'Find the last used cell with a formula and value
'ref -- http://www.vbaexpress.com/kb/getarticle.php?kb_id=83
Function RealLastUsed(ws As Worksheet) As Range
    Dim ColFormula As Range, ColValue As Range, RowFormula As Range, RowValue As Range
    Dim LastRow As Long, LastCol As Long
    Dim R As Long, C As Long
    Dim oShape As Shape
    
    With ws
        'Search by Columns and Rows
        On Error Resume Next
        Set ColFormula = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
        Set ColValue = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
        Set RowFormula = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        Set RowValue = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        On Error GoTo 0
 
        'Determine the last column
        If ColFormula Is Nothing Then
            LastCol = 0
        Else
            LastCol = ColFormula.Column
        End If
        If Not ColValue Is Nothing Then
            LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
        End If
 
        'Determine the last row
        If RowFormula Is Nothing Then
            LastRow = 0
        Else
            LastRow = RowFormula.Row
        End If
        If Not RowValue Is Nothing Then
            LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
        End If
 
         'Determine if any shapes are beyond the last row and last column
        For Each oShape In .Shapes
            R = 0
            C = 0
            On Error Resume Next
            R = oShape.TopLeftCell.Row
            C = oShape.TopLeftCell.Column
            On Error GoTo 0
            If R > 0 And C > 0 Then
                Do Until .Cells(R, C).Top > oShape.Top + oShape.Height
                    R = R + 1
                Loop
                R = R - 1   '   get rid of extra row
                If R > LastRow Then
                    LastRow = R
                End If
                Do Until .Cells(R, C).Left > oShape.Left + oShape.Width
                    C = C + 1
                Loop
                C = C - 1   '   get rid of extra col
                If C > LastCol Then
                    LastCol = C
                End If
            End If
        Next
    
        Set RealLastUsed = .Cells(LastRow, LastCol)
    
    End With
    
End Function

[BenChod]

I wish I could code like that.

[SamT]

That is one long piece of code to find the last row/col

It does more than that. Look at the link I took it from

I wish I could code like that.

Look at each Set... and each If... and in the For loop, at each Do... as a separate bit of code.

[SamT]

I did have to make two changes since it seemed to give me an extra row and column if there was a shape like the picture below w/o the 2 changes

G43 is the topmost row and leftmost column that do not have any shape in them. What would happen if you put something in F42?