Optimization/Cleanup Assistance (1 Viewer)

[jo15765]

Through some assistance here and through google, I have copy/pasted a frankenstien of some code together that does exactly what I need. My question tho, is if there is any ways of cleaning this up, or am I using any bad practices/principles that could/should be changed?

Thanks in advance to all!

Function Test()
Dim wb As Excel.Workbook, xlApp As Excel.Application
Dim rng As Object, ws As Object, y As Long
Dim LastRow As Long, lColumn As Long, x As Long, LastColumn As Long
Dim headerColumn As String, headerColumnTwo As String, strValue As String
Dim pivotWS As Excel.Worksheet, dataWS As Excel.Worksheet
Dim PCache As Excel.PivotCache, PTable As Excel.PivotTable
Dim PRange As Excel.Range
    
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False

Set wb = xlApp.Workbooks.Open("C:\Test\Excel\Test.xlsx", False, False)
Set ws = wb.Sheets(1)

ws.Rows("1:2").Delete Shift:=xlUp
ws.Rows("2:6").Delete Shift:=xlUp
ws.Rows("2:2").Delete Shift:=xlUp
wb.Sheets(1).Columns("B:H").EntireColumn.Delete
ws.Range("A1").Value = "empID"

wb.Save

LastRow = ws.Range("A" & ws.Rows.Count).End(-4162).Row
lColumn = ws.Range("XFD1").End(-4159).Column

For y = 2 To LastRow
    strValue = ""
   For x = 2 To lColumn
        strValue = strValue & "." & ws.Cells(y, x)
   Next x
    strValue = Right(strValue, Len(strValue) - 1)
    ws.Cells(y, lColumn + 1).Value = strValue
Next y

headerColumn = Number2Letter(lColumn + 1)

Range(headerColumn & "1").Value = "KitID"

wb.Save

CreateKitNames

headerColumnTwo = Number2Letter(lColumn + 2)

Range(headerColumnTwo & "1").Value = "empNames"

wb.Save

ws.Columns("H:I").Copy
Set ws2 = wb.Sheets.Add(After:=wb.Worksheets("QRS"))
ws2.Name = "Data"
ws2.Paste
xlApp.CutCopyMode = False
ws2.Range("$A$1:$B$" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
ws2.Sort.SortFields.Clear
ws2.Sort.SortFields.Add2 Key:=Range("A2:A" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws2.Sort
    .SetRange Range("A1:B" & LastRow)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
xlApp.Goto ws2.Range("A1"), True
ws2.Columns("A:A").EntireColumn.AutoFit

wb.Save

wb.Sheets.Add(Before:=Excel.ActiveSheet).Name = "PivotTable"

Set pivotWS = wb.Worksheets("PivotTable")
Set dataWS = wb.Worksheets("QRS")

LastColumn = dataWS.Cells(1, Columns.Count).End(xlToLeft).Column

Set PRange = dataWS.Cells(1, 1).Resize(LastRow, LastColumn)

Set PCache = Excel.ActiveWorkbook.PivotCaches.Create(SourceType:=Excel.xlDatabase, SourceData:=PRange)
Set PTable = PCache.CreatePivotTable(TableDestination:=pivotWS.Cells(3, 1), TableName:="TestPivotTable")

With PTable.PivotCache
    .RefreshOnFileOpen = False
    .MissingItemsLimit = Excel.xlMissingItemsDefault
End With

PTable.RepeatAllLabels xlRepeatLabels

wb.Save

With PTable.PivotFields("empNames")
    .Orientation = Excel.xlRowField
    .Position = 1
End With

With PTable.PivotFields("empID")
    .Orientation = Excel.xlDataField
    .Caption = "Count of empID"
   .Function = Excel.xlCount
End With

wb.Save

wb.Close
xlApp.DisplayAlerts = False
xlApp.Quit

End Function
Private Function Number2Letter(ColumnNumber As Integer)
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim ColumnLetter As String

ColumnLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)

Number2Letter = ColumnLetter
  
End Function
Function CreateNames()
    Dim dataColumn As Long
    Dim dataVal As String, letterVal As String, decodedVal As String
   
    dataColumn = Excel.Cells(1, Excel.Columns.Count).End(Excel.xlToLeft).Column
    outputColumn = dataColumn + 1
    tempCol1 = dataColumn + 2
    tempCol2 = dataColumn + 3
    
    Excel.Columns(dataColumn).Copy Excel.Columns(tempCol1)
    Excel.Cells(1, tempCol1).Delete
    
    Excel.Columns(tempCol1).RemoveDuplicates Columns:=Array(1)
    Excel.Columns(tempCol1).Sort Key1:=Excel.Columns(tempCol1), Order1:=xlAscending, Header:=xlN
    
    For i = 1 To Excel.Cells(1, tempCol1).End(Excel.xlDown).Row
        letterVal = Split(Cells(1, i).Address, "$")(1)
        Cells(i, tempCol2).Value = letterVal
    Next i
    
    For i = 2 To Excel.Cells(1, dataColumn).End(Excel.xlDown).Row
        decodedVal = Excel.WorksheetFunction.VLookup(Excel.Cells(i, dataColumn).Value, Excel.Range(Cells(1, tempCol1), Cells(Excel.Cells(1, tempCol1).End(Excel.xlDown).Row, tempCol2)), 2)
        Cells(i, outputColumn) = decodedVal
    Next i
    
    Excel.Columns(tempCol1).Delete
    Excel.Columns(tempCol1).Delete
    Excel.Columns(outputColumn).Select
    
End Function

 

[cheekybuddha]

Hi,

Do you have Option Explicit set at the top of [all] your code modules?

If not, then you should add it (above or below Option Compare Database).

If you do, then you must have a reference to Excel set, which kind of negates the benefits of late binding.

If you revolve this reference then you will need to declare all the constants and their values. (xlUp etc).

You probably don't need to use your Number2Letter() function since you have the column number already and you can use the .Cells collection rather than the .Range object.

Will comment further when I get back to a computer (on phone at the minute)

 

[cheekybuddha]

Hi again,

Your Number2Letter() and CreateNames() functions have references to an unqualified Excel object(s) - this will lead to hanging instances once you're done.

I guess you are actually using Early-binding, but have cobbled in some late-bound code - it might be useful to choose one method or the other and make the code consistent.

 

[jo15765]

Hi again,

Your Number2Letter() and CreateNames() functions have references to an unqualified Excel object(s) - this will lead to hanging instances once you're done.

I guess you are actually using Early-binding, but have cobbled in some late-bound code - it might be useful to choose one method or the other and make the code consistent.

Ah - I'll investigate this further. This explains why I would always have a "ghost" instance of Excel running in Task Manager even when the process had completely finished!

I do not have option explicit declared, I know that is best practice, I should have remembered that.

I have the reference for Excel added under Tools - References, does that determine if I'm using Early/Late Binding?

 

[jo15765]

how would I pass the instance of excel from the Function Test to Number2Letter() and CreateNames() so I do not get left with the hanging Excel reference?

 

[cheekybuddha]

Function CreateNames(ws As Object)
    Dim dataColumn As Long
    Dim dataVal As String, letterVal As String, decodedVal As String
  
    dataColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    outputColumn = dataColumn + 1
    tempCol1 = dataColumn + 2
    tempCol2 = dataColumn + 3
   
    ws.Columns(dataColumn).Copy ws.Columns(tempCol1)
    ws.Cells(1, tempCol1).Delete
   
    ws.Columns(tempCol1).RemoveDuplicates Columns:=Array(1)
    ws.Columns(tempCol1).Sort Key1:=ws.Columns(tempCol1), Order1:=xlAscending, Header:=xlNo
   
    For i = 1 To ws.Cells(1, tempCol1).End(xlDown).Row
        letterVal = Split(ws.Cells(1, i).Address, "$")(1)
        ws.Cells(i, tempCol2).Value = letterVal
    Next i
   
    For i = 2 To ws.Cells(1, dataColumn).End(xlDown).Row
        decodedVal = ws.Parent.Parent.WorksheetFunction.VLookup(ws.Cells(i, dataColumn).Value, ws.Range(ws.Cells(1, tempCol1), ws.Cells(ws.Cells(1, tempCol1).End(xlDown).Row, tempCol2)), 2)
        ws.Cells(i, outputColumn) = decodedVal
    Next i
   
    ws.Columns(tempCol1).Delete
    ws.Columns(tempCol1).Delete          ' <-- Is this repeated on purpose??
    ws.Columns(outputColumn).Select
   
End Function

Then, in your code:

' ...
  Call CreateNames(wb)
' ...

(I can't find CreateNames in your main code - is it where you have CreateKitNames?)

WRT. Number2Letter(), you would change it to:

Private Function Number2Letter(ColumnNumber As Integer, ws As Object)
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim ColumnLetter As String

ColumnLetter = Split(ws.Cells(1, ColumnNumber).Address, "$")(1)

Number2Letter = ColumnLetter
 
End Function

You would then change your main code to:

' ...
headerColumn = Number2Letter(lColumn + 1, ws)
' ...

HOWEVER, you don't need it! you can change your main code to:

' ...
'  headerColumn = Number2Letter(lColumn + 1)   DELETE THIS LINE

ws.Cells(1, lColumn + 1).Value = "KitID"

wb.Save
' ...

I have just noticed a few unqualified Range references in your main code - these will cause hangs if not dealt with too.

hth,

d

 

[Isaac]

David I was curious why you chose
ws.Parent.Parent.WorksheetFunction

? rather than the excel application, is there a particular reason.

 

[cheekybuddha]

David I was curious why you chose
ws.Parent.Parent.WorksheetFunction

? rather than the excel application, is there a particular reason.

Since I passed in a worksheet object, you need to be able to get to the Application object to refer to WorksheetFunction.

Worksheet.Parent -> Workbook
Workbook.Parent -> Application

 

[Isaac]

Oops, of course, that's what I get for not reading carefully enough. I missed that this was not part of the main procedure.

 

[jo15765]

@cheekybuddha - when my code hits this line

CreateKitNames (wb)

I also tried it as ws since that is what we are passing in - I get the error:

Run-time error '438':
Object doesn't support this property or method

And just for clarification this is how the method is setup

Function CreateKitNames(ws As Object)

 

[cheekybuddha]

Yes, sorry, it should have been called:
Call CreateKitNames(ws)

However, it's likely there may be errors since it's untested code.

When the error occurs, which line is highlit if you choose 'Debug'?

 

[jo15765]

This is the line highlighted

Call CreateKitNames(ws)

 

[cheekybuddha]

Ah OK!

Can you set a breakpoint on that line.

When the breakpoint hits, use the F8 button to step in to the function line by line.

Remember which line was selected when the next error occurs.

 

[jo15765]

It won't step into the function.

If I add a breakpoint to that line, the second I press F8 the error is thrown.

 

[cheekybuddha]

Did you add Option Explicit?

Is anything shown if you compile (Debug menu -> Compile)

Also, you did rename the function from CreateNames() to CreateKitNames() ?

 

[jo15765]

I added option explicit, and declared all variables as this

    Dim dataColumn As Long, outputColumn As Long, tempCol1 As Long, tempCol2 As Long
    Dim i As Long
    Dim dataVal As String, letterVal As String, decodedVal As String

And a debug - compile shows no issues, but running the code, the same line still throws the same issue.

 

[cheekybuddha]

Weird that you can't step in.

Ok, see the breakpoint on this line within the function:

' ...
    dataColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
' ...

Hopefully it will break in there and you can F8 on through.

 

[jo15765]

won't even reach the method

I added a breakpoint on the above line, but it still hits the same line and throws the error

 

[cheekybuddha]

Can you post the whole definition of CreateKitNames() as you have it.

Is it in its own module or a form module?

 

[jo15765]

It's in it's own function

Function CreateNames(ws As Object)
    Dim dataColumn As Long, outputColumn As Long, tempCol1 As Long, tempCol2 As Long
    Dim i As Long
    Dim dataVal As String, letterVal As String, decodedVal As String
  
    dataColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    outputColumn = dataColumn + 1
    tempCol1 = dataColumn + 2
    tempCol2 = dataColumn + 3
   
    ws.Columns(dataColumn).Copy ws.Columns(tempCol1)
    ws.Cells(1, tempCol1).Delete
   
    ws.Columns(tempCol1).RemoveDuplicates Columns:=Array(1)
    ws.Columns(tempCol1).Sort Key1:=ws.Columns(tempCol1), Order1:=xlAscending, Header:=xlNo
   
    For i = 1 To ws.Cells(1, tempCol1).End(xlDown).Row
        letterVal = Split(ws.Cells(1, i).Address, "$")(1)
        ws.Cells(i, tempCol2).Value = letterVal
    Next i
   
    For i = 2 To ws.Cells(1, dataColumn).End(xlDown).Row
        decodedVal = ws.Parent.Parent.WorksheetFunction.VLookup(ws.Cells(i, dataColumn).Value, ws.Range(ws.Cells(1, tempCol1), ws.Cells(ws.Cells(1, tempCol1).End(xlDown).Row, tempCol2)), 2)
        ws.Cells(i, outputColumn) = decodedVal
    Next i
   
    ws.Columns(tempCol1).Delete
    ws.Columns(tempCol1).Delete          ' <-- Is this repeated on purpose??
    ws.Columns(outputColumn).Select
   
End Function