Cellen verwijdere die niet aan het een of andere creteria voldoen

[MarcVanloffelt]

Beste mensen,

ik zou graag in een file alle cellen die niet aan één van de criteria voldoen verwijderen en de cellen naar links verschuiven.

Criteria zijn bepaalde stukken van een cijferreeks. Ik heb volgende code al ergens kunnen terugvinden maar hij verwijdert nu alles...

Iemand een idee?

Sub DeleteCells()
Dim criteriarange As Range
Dim criteriacell As Range
Set criteriarange = Range("A1:Z200")
For Each criteriacell In criteriarange
If criteriacell.Value <> "*067*" Or criteriacell.Value <> "*138*" Then
criteriacell.ClearContents
End If
Next criteriacell
End Sub

Met vriendelijke groeten,
Marc

 

[emields]

misschien heb je hier iets aan.

https://www.helpmij.nl/forum/announcement.php?f=5

 

[MarcVanloffelt]

Ok, denk dat ik het begrepen heb emields, sorry, beginnersfoutje

In het voorbeeldbestandje staan een twintigtal kolommen die ik verkregen heb door tekst naar kolommen met de komma als separator.

Nu zou ik graag alle cellen die NIET met 13800 of 06700 beginnen verwijderen en de cellen naar links schuiven. Daarna, in het ideale geval, de cellen beperken tot de eerste 10 cijfers van elke cel.

Ik weet niet of het mogelijk is maar hoop op positieve feedback

Nogmaals bedankt voor de tip(s) en groetjes,
Marc

 

[VenA]

Plaats het bestand eens zonder dat je tekst naar kolommen hebt gebuikt.

 

[MarcVanloffelt]

In bijlage het bestand zonder tekst naar kolommen

Alvast bedankt om even ernaar te kijken :thumb:

Marc

 

[VenA]

Hoe kan Blad2 compleet anders zijn dan Blad1? Al andere bewerkingen gedaan? Als iets met VBA gemaakt moet worden is het meestal maatwerk en als je met verschillende voorbeelden komt die niet duidelijk zijn dan blijft het allemaal giswerk. Waarom staan er soms dubbele (( en soms enkele idem voor )) ?

 

[MarcVanloffelt]

Beste VenA,

zo komt het uit een extern systeem gerold, denk dat het afsluiten altijd met een )) gebeurd. Heb zelf, jammer genoeg, het gissen waarom soms 1x( en dan weer 2x(

In het eerste tabblad heb ik idd wat bewerkingen gedaan. In het tweede tabblad zijn nog geen bewerkingen gedaan. Zoals je kan zien zijn sommige rijen leeg en dienen ook leeg te blijven

 

[VenA]

Zet dan maar in Blad3 wat de verwachte uitkomst moet worden.

Wat is eigenlijk de bron van dit bestand?

 

[MarcVanloffelt]

Heb het even in een aantal rijen met de hand aangepast.

zie vooral rij 138 tem 164.

Daar waar een tekenreeks begint met 067 wil ik 10 cijfers tonen (67 + de volgende 8), bij 138 wil ik 11 cijfers tonen (138 + de volgende 8)

 

[VenA]

Wat het allemaal moet worden zal voor jou duidelijk zijn.

Om maar ergens te beginnen.

Sub VenA()
  ar = Sheets("Blad2").UsedRange.Columns(1)
  Set d = CreateObject("Scripting.Dictionary")
  For j = 2 To UBound(ar)
    If Left(ar(j, 1), 4) = "AKTG" Then
      x = Split(Replace(ar(j, 1), "AKTG (", ""), ",")
      Dim a(25)
      t = 0
      For jj = 0 To UBound(x)
        If InStr("067138", Left(x(jj), 3)) Then
          a(t) = "'" & Left(x(jj), 10)
          t = t + 1
         End If
       Next jj
       d(d.Count + 1) = a
    End If
  Next j
  Sheets("Result").Cells(1).Resize(d.Count, 25) = Application.Index(d.items, 0, 0)
End Sub

 

[MarcVanloffelt]

Alvast een mooie start :thumb:

Nu, de lege rijen zouden niet mogen verwijderd worden.

Maar, als ik de code zie moet het toch ook perfect mogelijk zijn om aan de informatie op blad 1 de cellen die NIET met 138 of 067 beginnen te wissen, niet?

 

[VenA]

Wat wil je met die lege rijen dan? Ik heb het idee dat de vraag lang niet volledig is. Door wat zaken te verplaatsen in de code zal het wel mogelijk zijn.

Sub VenA1()
  ar = Sheets("Blad2").UsedRange.Columns(1)
  Set d = CreateObject("Scripting.Dictionary")
  For j = 2 To UBound(ar)
    ReDim a(25)
    If Left(ar(j, 1), 4) = "AKTG" Then
      x = Split(Replace(ar(j, 1), "AKTG (", ""), ",")
      t = 0
      For jj = 0 To UBound(x)
        If InStr("067138", Left(x(jj), 3)) Then
          a(t) = Left(x(jj), 10 - (Left(x(jj), 3) = "138"))
          t = t + 1
         End If
       Next jj
    End If
    d(d.Count + 1) = a
  Next j
  Sheets("Result").Cells(1).Resize(d.Count, 25) = Application.Index(d.items, 0, 0)
End Sub

 

[MarcVanloffelt]

Dank je wel VenA, hier geraak ik al een stuk verder mee