Sortering af kolonner der indeholder formel

Cellen har indhold når der står en formel (indholdets længde er ikke 0)

Hvis der kun indsættes en formel i en kolonne, kan denne skjules med denne tilføjelse:

  If Len(rCell.Value) = 0 Then
            Set rTest = rCell.End(xlDown)
      If rTest.Row = Rows.Count And Len(rTest.Value) = 0 Or (rTest.HasFormula = True And rTest.Value = 0) Then
                  Columns(rCell.Column).Hidden = True
        Else
      End If
  End If

Det virkede faktisk.
Bortset fra at den også sorterer de kolonner væk, hvor der er et resultat vist - hvad skyldes det?

Har testet med en formel med værdi - kolonnen slettes ikke!

Du er velkommen til at sende filen - @-adresse under min profil.

Sub Sorterkolonner()
'Gennemløber de første 26 kolonner og
'skjuler dem, hvis de er tomme.
Dim rCell As Range
Dim rTest As Range
Dim lCol As Long
On Error GoTo Fejl
'Skærmopdatering slås fra for at øge hastigheden.
Application.ScreenUpdating = False

'Vi gennemløber nu kolonnerne fra venstre mod højre.
For lCol = 0 To 2000 Step 1
  'rCell sættes = cellen lCol til højre
  'for celle A1.
  Set rCell = Range("B3").Offset(0, lCol)
  'Hvis cellen er tom
  If Len(rCell.Value) = 0 Then
      'Gå til første celle nedefter, som har
      'et indhold. Hvis der ikke er nogen
      '"på vejen," havner vi i den nederste celle.
      Set rTest = rCell.End(xlDown)
      If rTest.Row = Rows.Count And Len(rTest.Value) = 0 Or (Cells(75, rCell.Column).Value = 0) Then    '<-- justeret
        'Kolonnen skjules.
        Columns(rCell.Column).Hidden = True
      End If
  End If
Next
BeforeExit:
Set rCell = Nothing
Set rTest = Nothing
'Skærmopdatering slås til igen
Application.ScreenUpdating = True
Exit Sub
Fejl:
MsgBox Err.Description & " Procedure SkjulTommeKolonner"
Resume BeforeExit
End Sub


Rem Revideret:
Sub sorterrækker()
Dim CheckRange As Range, cc As Object, ræk As String
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Set CheckRange = ActiveSheet.Range("BLF4:BLF75")

    For Each cc In CheckRange.Cells
        If cc.Value = 0 Then
            ræk = cc.Row
            Rows(ræk & ":" & ræk).Select
            Selection.EntireRow.Hidden = True
        End If
    Next cc

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub