Macro Decending sortering werkt niet

[carloschouw]

Goedemorgen,

Ik zit met een uitdaging waar ik geen raad mee weet. Ik werk met een knop in tabblad DATA wat gegevens selecteert, kopieert en plakt in DATAVERZAMELBESTAND. Daarna moet in kolom Q de waardes gesorteerd worden van nieuw naar oud. Dat doe ik middels deze code:

    ActiveWorkbook.Worksheets("DatumVerzamelbestand").AutoFilter.Sort.SortFields. _
        Add Key:=Range("Q1:Q5000"), SortOn:=xlSortOnValues, Order:=xlDecending, _
        DataOption:=xlSortNormal

Het probleem zit hem dat ik in tabblad DATA het bereik C28 t/m T42 selecteer, deze niet allemaal voorzien zijn van inhoud maar wel van een formule. De 'blanco' regels worden dus ook geselecteerd voor kopie en geplakt (waardes) waardoor het in feite 'lege cellen' zijn geworden. Met CTRL +pijl naar beneden zie je de 'lege cellen bereik' staan. Nu moet er, denk ik, voordat het sorteren (decending) begint de 'lege cellen' verwijderd worden maar heb geen idee hoe ik dat zou kunnen doen(de lege cellen staan altijd onderaan)

Iemand een idee?

 

[cow18]

selects en activates zijn een beetje uit den boze

Sub DatumStempel()
'
' DatumStempel Macro
'

'
    Dim iLeeg  As Integer
    Set c = Sheets("Data").Range("C28:C42")                          'C-kolom van je schema
    iLeeg = WorksheetFunction.CountBlank(c)                          'tel daarvan de lege cellen die normaal onderaan staan
    MsgBox c.Resize(c.Rows.Count - iLeeg, 18).Address                'straks mag deze regel weg, dit bereik gaan we kopieren
    c.Resize(c.Rows.Count - iLeeg, 18).Copy                          'kopieer
    Sheets("DatumVerzamelbestand").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False    'plak
    With Worksheets("DatumVerzamelbestand").Range("A1").CurrentRegion    'je verzamelgegevens
        MsgBox .Address                                              'deze regel mag straks weg
        .Sort .Range("Q1"), xlDescending, Header:=True               'sorteren op de Q-kolom
        .RemoveDuplicates Columns:=1, Header:=xlYes                  'duplicaten van A verwijderen
        .Columns("P:Q").NumberFormat = "m/d/yyyy"
    End With

    Application.Goto Sheets("SmeerschemaOverzicht").Range("A1"), 1

End Sub

 

[carloschouw]

Helemaal top!

Wat mee getest en het werkt super! Dank voor je hulp en uitleg.

Groet, Carlo

 

[snb]

Door een onhandige opbouw van het werkblad maak je het jezelf onnodig moeilijk.
Gebruik nooit samengevoegde cellen
Gebruik altijd kolom A en rij 1 en zet een gegeven in cel A1.

Uitgaande van de huidige opbouw:

Sub M_snb()
    Blad1.Cells(27, 3).CurrentRegion.SpecialCells(-4123, 2).Areas(1).Offset(, -1).Resize(, 18).Copy Blad2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
End Sub

 

[carloschouw]

Hoi cow18,

Ik snap iets niet. Ik heb het bereik iets vergroot, de code daarop aangepast maar krijg een foutmelding

c.Resize(c.Rows.Count - iLeeg, 21).Copy

Ik heb de , 18 veranderd naar ,21 wegens de toevoegingen van kolommen (hiernaast ook wat rijen toegevoegd) Wanneer ik jouw code test doet hij het perfect, alleen naar wat toevoegen van kolommen en rijen komt deze foutmelding. Wat doe ik verkeerd?

In de bijlage de aangepaste code.

Groet, Carlo

 

[cow18]

Je had in je bereik een "W" staan, daardoor telde hij alle lege cellen in een groot bereik en kreeg je als resultaat een negatief aantal, waarop hij vast liep.
Hieronder nog een beetje eenvoudiger, gewoon door afvragen van het aantal rijen, dat je zelf bepaald had via die gedefinieerde naam "AantalAfd"

Sub DatumStempel()

    Dim iRijen As Integer
    iRijen = [Data!AantalAfd]
    Sheets("Data").Range("C28").Resize(iRijen, 21).Copy              'kopieer
    Sheets("DatumVerzamelbestand").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues    'plak
    With Worksheets("DatumVerzamelbestand").Range("A1").CurrentRegion    'je verzamelgegevens
        .Sort .Range("Q1"), xlDescending, Header:=True               'sorteren op de Q-kolom
        .RemoveDuplicates Columns:=1, Header:=xlYes                  'duplicaten van A verwijderen
        .Columns("P:Q").NumberFormat = "m/d/yyyy"
    End With

    Application.Goto Sheets("Data").Range("A1"), 1

End Sub

 

[snb]

Als 'Select' en 'Activate' ontbreken is Application.goto overbodig.

 

[carloschouw]

Top, deze werkt perfect!

Mijn dank is GROOT