Gfrktyl

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

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.