2
\$\begingroup\$

I have to create a custom table (like a pivot table), where users can find immediately the total of items, and when clicking on data, get the db page correctly filtered.

My code works fine, but continuous improvement pushes me to look for more efficient code.

Thanks for every contributes.

Sub AddTab1(ByVal c As Integer, str As String)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim dbSh As Worksheet, tabSh As Worksheet
Dim ini As Date, fin As Date, tmp As Date, s As Range
Set dbSh = Sheets("db_Out")
Set tabSh = Sheets("Tab")
Dim arrTab(), rng As Range, i As Integer, cl As Range
Dim colIndex As Long, lrw As Integer, lcl As Integer
Dim firstCell As Range
Dim lastCell As Range
ini = Now()
If dbSh.Cells(2, c) = vbNullString Then MsgBox "Non ci sono dati valorizzati da estrapolare", vbInformation, "Cf_utility.info": Exit Sub
tabSh.Select

With tabSh
Set s = Range(str)
    s.Select
    If s.Offset(1) = vbNullString Then GoTo continue
    s.Select
    lrw = Columns(s.Column).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row 'Selection.End(xlDown).row
    lcl = Selection.End(xlToRight).Column
    s.Offset(1).Select
    .Range(Selection, Cells(lrw, lcl)).ClearContents
    s.Offset(2).Select
    .Range(Selection, Cells(lrw, lcl)).Select
    Selection.Delete Shift:=xlUp
    s.Offset(1).Select
End With

continue:
With dbSh
    .AutoFilterMode = False
    .Cells.EntireColumn.Hidden = False
    Set firstCell = .Cells(2, c)
    Set lastCell = .Cells(.Rows.Count, c).End(xlUp)
    Set rng = .Range(firstCell, lastCell)
    rng.Copy
End With
    tabSh.Select
    s.Offset(1).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    tabSh.Sort.SortFields.Clear
    tabSh.Sort.SortFields.Add key:=s, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
With tabSh.Sort
    .SetRange Range(s.Offset(1), Cells(Columns(s.Column).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row, s.Column))
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
s.Select
s.Offset(1).Select
Set rng = Range(Selection, Cells(Columns(s.Column).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row, s.Column))
rng.RemoveDuplicates Columns:=1, Header:=xlNo

'KPI2-1 (Prelievo)
s.Select
lrw = Selection.End(xlDown).row
lcl = Selection.End(xlToRight).Column
ReDim arrTab(4 To lrw, 1 To lcl - 1)
s.Offset(1).Select
Set rng = Range(Selection, Selection.End(xlDown))
'c = D_KPI2_1        'Kpi KPI2_1
For Each cl In rng.Cells
    arrTab(cl.row, 2) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "STD", dbSh.Columns(V_KPI2_1), 0.9) + WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "STD", dbSh.Columns(V_KPI2_1), 1)
    If Not arrTab(cl.row, 2) > 0 Then arrTab(cl.row, 2) = Empty
    arrTab(cl.row, 3) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "STD", dbSh.Columns(V_KPI2_1), "Out of KPI")
    If Not arrTab(cl.row, 3) > 0 Then arrTab(cl.row, 3) = Empty
    arrTab(cl.row, 4) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "STD", dbSh.Columns(V_KPI2_1), "Backlog")
    If Not arrTab(cl.row, 4) > 0 Then arrTab(cl.row, 4) = Empty
    arrTab(cl.row, 5) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "PRIORITY", dbSh.Columns(V_KPI2_1), 0.95) + WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "PRIORITY", dbSh.Columns(V_KPI2_1), 1)
    If Not arrTab(cl.row, 5) > 0 Then arrTab(cl.row, 5) = Empty
    arrTab(cl.row, 6) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "PRIORITY", dbSh.Columns(V_KPI2_1), "Out of KPI")
    If Not arrTab(cl.row, 6) > 0 Then arrTab(cl.row, 6) = Empty
    arrTab(cl.row, 7) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "PRIORITY", dbSh.Columns(V_KPI2_1), "Backlog")
    If Not arrTab(cl.row, 7) > 0 Then arrTab(cl.row, 7) = Empty
    arrTab(cl.row, 8) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "AOG", dbSh.Columns(V_KPI2_1), 1)
    If Not arrTab(cl.row, 8) > 0 Then arrTab(cl.row, 8) = Empty
    arrTab(cl.row, 9) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "AOG", dbSh.Columns(V_KPI2_1), "Out of KPI")
    If Not arrTab(cl.row, 9) > 0 Then arrTab(cl.row, 9) = Empty
    arrTab(cl.row, 10) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "AOG", dbSh.Columns(V_KPI2_1), "Backlog")
    If Not arrTab(cl.row, 10) > 0 Then arrTab(cl.row, 10) = Empty
    For i = 2 To 10
        arrTab(cl.row, 1) = arrTab(cl.row, 1) + arrTab(cl.row, i)
    Next
    If arrTab(cl.row, 1) < 1 Then arrTab(cl.row, 1) = Empty
Next
Range(s.Offset(1, 1), Cells(lrw, s.Offset(, 10).Column)) = arrTab()

s.Select
StartCl
lcl = Selection.End(xlToRight).Column
lrw = Selection.End(xlDown).row
Range(Selection.Offset(1), Selection.Offset(1, 11)).Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
s.Select
CleanTab
s.Select
InsLink

fin = Now()
tmp = fin - ini
Debug.Print tmp
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False


End Sub

My english is maybe not perfectly understandable, so here is a image

fabrizio

enter image description here

\$\endgroup\$
5
\$\begingroup\$

A couple quick house-keeping issues first:

  • Get rid of your old commented out code - it's simply adding noise.
  • Your indentation is inconsistent. I had to run this through an indenter before I could tell what this section was supposed to be doing:

    End With
        tabSh.Select
        s.Offset(1).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        tabSh.Sort.SortFields.Clear
        tabSh.Sort.SortFields.Add key:=s, _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortTextAsNumbers
    With tabSh.Sort
    
  • You should move your variables closer to where you're using them, and give them meaningful names instead of things like s, lcl, lrw, and rng. s is basically Selection, so I'd get rid of that entirely (see below), but the others would be better named as something like lastColumn, lastRow, and searchRange. Between the meaningless identifiers, the "Dim-wall" at the top of the procedure, and the multiple declaration lines like the ones below, I basically gave up on trying to keep them all straight when I was reading through the procedure.

    Dim arrTab(), rng As Range, i As Integer, cl As Range
    Dim colIndex As Long, lrw As Integer, lcl As Integer
    
  • Remove the bench-marking code from your procedure. It doesn't do any meaningful work, and it took me a while to realize what it was actually there for (not helped by the cryptic variable names ini, fin, and tmp. If you need to benchmark code, call it from a dedicated benchmarking procedure:

    'Note that I named the parameters 'foo' and 'bar', because they mean roughly
    'as much to me as 'c' and 'str' do.
    Private Sub BenchmarkAddTab1(foo As Integer, bar As String)
        Dim startTime As Single
        startTime = Timer
    
        AddTab1 foo, bar
    
        Debug.Print "AddTab1 " & foo & ", """ & bar & """ took "  & Timer - startTime & " seconds."
    End Sub
    

I would suggest starting out by reading How to avoid using Select in Excel VBA over on SO. This will probably have more of a performance impact that anything else I'm going to recommend (other than maybe the use of WorksheetFunction).

That said, if your performance is reasonable, I'd focus on the more glaring issues in your code before you even start on that. I'd pretty much plan on re-writing most of this.


Even though you get references to the worksheets that you'll be dealing with later here...

Set dbSh = Sheets("db_Out")
Set tabSh = Sheets("Tab")

... you continually reference the ActiveSheet, select ranges, and use the Selection object. Note that since these are basically hard-coded, you should be using the code name of the worksheets instead - it's not like they're going to change, right?


This With block isn't really doing that much:

tabSh.Select

With tabSh
    Set s = Range(str)
    s.Select
    If s.Offset(1) = vbNullString Then GoTo continue
    s.Select
    lrw = Columns(s.Column).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'Selection.End(xlDown).row
    lcl = Selection.End(xlToRight).Column
    s.Offset(1).Select
    .Range(Selection, Cells(lrw, lcl)).ClearContents
    s.Offset(2).Select
    .Range(Selection, Cells(lrw, lcl)).Select
    Selection.Delete Shift:=xlUp
    s.Offset(1).Select
End With

Every single call to Range, Columns, and Cells within the With block is referring implicitly to the ActiveSheet. If they're supposed to be referring to tabSh, you need the dereference operator (the dot - .) in front of them.


The use of Goto for flow control is completely unnecessary. You can invert your If statement to make it clear. I actually had to use Ctrl-F to find it, and that's a really bad sign for readability. Just do this:

With tabSh
    Set s = Range(str)
    s.Select
    If s.Offset(1) <> vbNullString Then
        s.Select
        lrw = Columns(s.Column).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'Selection.End(xlDown).row
        lcl = Selection.End(xlToRight).Column
        s.Offset(1).Select
        .Range(Selection, Cells(lrw, lcl)).ClearContents
        s.Offset(2).Select
        .Range(Selection, Cells(lrw, lcl)).Select
        Selection.Delete Shift:=xlUp
        s.Offset(1).Select
    End If
End With

...and no more Goto


This line...

Set rng = Range(Selection, Cells(Columns(s.Column).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row, s.Column))
'c = D_KPI2_1        'Kpi KPI2_1
For Each cl In rng.Cells

...is dangerous because you never test the return value of the Find call to make sure that it isn't Nothing. This is just waiting for run-time errors. There are literally hundreds of questions on SO because of this oversight.


The most glaring performance issue is in your main loop with code like this:

arrTab(cl.Row, 2) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "STD", dbSh.Columns(V_KPI2_1), 0.9) + WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "STD", dbSh.Columns(V_KPI2_1), 1)
If Not arrTab(cl.Row, 2) > 0 Then arrTab(cl.Row, 2) = Empty
arrTab(cl.Row, 3) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "STD", dbSh.Columns(V_KPI2_1), "Out of KPI")
If Not arrTab(cl.Row, 3) > 0 Then arrTab(cl.Row, 3) = Empty
arrTab(cl.Row, 4) = WorksheetFunction.CountIfs(dbSh.Columns(c), cl.Value, dbSh.Columns(TypeTra), "STD", dbSh.Columns(V_KPI2_1), "Backlog")
If Not arrTab(cl.Row, 4) > 0 Then arrTab(cl.Row, 4) = Empty

Not only is WorksheetFunction horrendously slow, you're calling it repeatedly inside a tight loop. It's hard to tell from your question description what these CountIfs calls are supposed to be doing, but I guarantee that tracking the manually counts in some sort of collection would destroy that in performance. You're writing VBA, not setting up formulas on a worksheet - simple functions like this shouldn't be delegated back to the worksheet.

\$\endgroup\$
  • \$\begingroup\$ #Comintern 1th thanks for the lesson !! the bad habit of writing code for personal use never comments, absurd variable name,... part of old code disable only wiht "'". At the end of yr post are the 1th problem, count item recurrence in one table using with two or more criteria. I'm sure that use WorksheetFunction.CountIfs isn't the best way but it's the only that I know. Immediatly I undertake to rewrite the code, you can tell me an alternative at WorksheetFunction.CountIfs, I need just the idea, then I'll learn Hou to use \$\endgroup\$ – Fabrizio Nov 13 '18 at 8:39
  • \$\begingroup\$ @Fabrizio WorksheetFunction.CountIfs certainly works, but it's a late bound call to the Excel function, and carries a bunch of overhead. Like I said, I wouldn't worry about it unless the performance of the procedure isn't acceptable (and this was tagged performance). If I were looking to speed the function up, that's where I'd start though. \$\endgroup\$ – Comintern Nov 13 '18 at 13:39
  • \$\begingroup\$ I've rewrite the code, now is much clear and I wrote some note to explain the code, thank to my teacher @Comintern As I allready wrote, this code run, I'm not very satisfat to the performance, If someone want suggest a different method to count the event I'll be happy. here I put one copy of my file, usually i use a ribbon to call each functions, in thi case I've insert one cmd on Tab sheet, 1drv.ms/x/s!AudrtvrEdOq0jRrTV4GNV2tRIbxb \$\endgroup\$ – Fabrizio Nov 14 '18 at 15:28

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.