PDA

View Full Version : Review Code for Efficiency



BenChod
06-07-2017, 09:23 AM
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
06-07-2017, 11:59 AM
I tbhimk this ill work :D
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
06-07-2017, 01:32 PM
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
06-07-2017, 04:34 PM
Change ".Column" to ".EntireColumn"

:banghead:

".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
06-08-2017, 05:01 AM
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
06-08-2017, 06:20 AM
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
06-08-2017, 06:49 AM
That is one long piece of code to find the last row/col

Paul_Hossler
06-08-2017, 07:45 AM
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


19432





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
06-08-2017, 08:35 AM
I wish I could code like that.

SamT
06-08-2017, 11:01 AM
That is one long piece of code to find the last row/colIt 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
06-08-2017, 11:10 AM
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?