Celinhoud wissen wanneer cel links ernaast leeg is (binnen een bereik afspelen)

Status
Niet open voor verdere reacties.
R

Robert Smidt

Gebruiker
Lid geworden
26 mei 2009
Berichten
901
Beste Helpmij'ers,

Ik heb via dit medium een code ontvangen om lege regels op te schuiven (zie onder), dit werkt overigens perfect, maar nu wil ik graag dat de code aangeroepen wordt wanneer binnen een bereik (A166:C180) in kolom B een waarde ontbreekt en het systeem automatisch de waarde ernaast in kolom C wist. Hierdoor ontstaat een lege regel. Onderstaande code dient dan aangesproken te worden om alle regels onder elkaar te zetten.

Mijn vraag: lukt het een code te maken om het eerste probleem op te lossen? M.a.w. in kolom B staan formules en op regel 168 (zie bijlage) geeft deze formule de waarde van een lege cel aan, echter is cel C168 gevuld. In dit geval moet hij in kolom C168 de waarde, in dit geval "Rabo", deleten. Hierdoor krijg je een lege regel/cel. Omdat in kolom B alleen maar formules staan hoeft het systeem hier niets mee te doen, het enige wat deze moet doen is in kolom C "Rabo" te wissen en vervolgens onderstaande code aan te spreken.

Op dit moment wordt de code handmatig aangeroepen vanuit een sub module. Het zou fijn zijn dat het automatisch gaat wanneer het systeem in kolom B een lege cel tussen de gevulde cellen ontdekt en dan de code activeert.

Code: 
Dim sv, arr, i As Long
sv = Range("c166:c180")
arr = sv
  For i = 1 To UBound(sv)
    If sv(i, 1) <> "" Then
       n = n + 1
       arr(n, 1) = sv(i, 1)
    End If
  Next i
  Cells(166, 3).Resize(15).ClearContents
  Cells(166, 3).Resize(n) = arr

Ik hoop dat het voorbeeld helderheid geeft in mijn uitleg. Alvast hartelijk dank.

RobertBekijk bijlage Opschuiven.xlsm
 
zo?
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    For i = 166 To 180
        If Cells(i, 2).Value = "" Then
            Cells(i, 3).Value = ""
            test
        End If
    Next
End Sub
 
Code: 
Private Sub Worksheet_Calculate()
Dim sv, i As Long
Application.EnableEvents = False
sv = Range("b166:c180")
  For i = 1 To UBound(sv)
    If sv(i, 1) <> "" Then
       n = n + 1
       sv(n, 2) = sv(i, 2)
    End If
  Next i
  Cells(166, 3).Resize(15).ClearContents
  Cells(166, 3).Resize(n) = Application.Index(sv, [row(1:15)], 2)
Application.EnableEvents = True
End Sub
 
De code werkt perfect.

Ik heb nog even een tweede vraag. De code vindt plaats binnen een bereik van C166 t/m C180. Kan ik deze code ook exact kopiëren wanneer deze naast het bereik van C166 t/m C180 ook binnen bereik C182 t/m C198 dezelfde functie heeft?

Hoef ik dan alleen onderstaande te wijzigen in C182:C198, of werkt dat niet zo?
Code: 
 sv = Range("c166:c180")
 Cells(166, 3).Resize(15).ClearContents
  Cells(166, 3).Resize(n) = Application.Index(sv, [row(1:15)], 2)
 
Code: 
Private Sub Worksheet_Calculate()
Dim sv, i As Long, n As Long,x as long
Application.EnableEvents = False
For Each sv In Array(Range("b166:c180"), Range("b182:c198"))
 sv = sv
  For i = 1 To UBound(sv)
    If sv(i, 1) <> "" Then
       n = n + 1
       sv(n, 2) = sv(i, 2)
    End If
  Next i
  x = x + 1
  Cells(IIf(x = 1, 166, 182), 3).Resize(IIf(x = 1, 15, 17)).ClearContents
  Cells(IIf(x = 1, 166, 182), 3).Resize(IIf(x = 1, 15, 17)) = Application.Index(sv, IIf(x = 1, [row(1:15)], [row(1:17)]), 2)
 Erase sv
 n = 0
 Next sv
Application.EnableEvents = True
End Sub
 
Sorry voor de late reactie. Ik ben langere tijd met de code aan het experimenteren geweest. De laatste code werkt prima in het demobestand (zie bijlage), echter gebruik ik de code in een enorm groot bestand waar diverse codes staan met verbanden naar andere werkbladen. Helaas is het ondoenlijk om dat grote bestand te uploaden. In de meeste gevallen ben ik enorm geholpen door een demobestandje aan te maken, alleen geeft deze oplossing een conflict met een andere code en ik wil jullie absoluut niet lastig vallen met een enorme hoeveelheid aan codes.

Tijdens het experimenteren ben ik erachter gekomen dat de oplossing het volgende is: wanneer binnen een bereik in kolom C één of meer cellen gevuld zijn en op dezelfde regel naast de gevulde cel kolom B de cel leeg is (alleen een formule aanwezig), dat het systeem dan alles binnen dat bereik in kolom C wist (delete).

In het voorbeeld bestand staat ING in kolom C en op dezelfde regel is kolom B leeg. Wanneer een dergelijke situatie zich voordoet, dient alles gewist te worden. Nadat alles gewist is moet een andere code (deze staat in het hoofdbestand) alle actuele regels weer vullen middels een goto opdracht is mijn inschattingBekijk bijlage Opschuiven.xlsm. Ik weet alleen niet of dat mogelijk is. Eerst maar even kijken wat het effect is wanneer het systeem alles binnen het bereik leeg maakt.
 
Het conflict wat je hebt met andere code is de change-event denk ik.

Voordat ik allerlei code uit de hoge hoed tover en dat dat het ook net niet helemaal is stel ik voor om eerst de change_event aan te passen.

Stel hier het bereik van toepassing in.
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    if not intersect(target, [COLOR=#0000ff]range("a1:a10")[/COLOR]) is nothing then 
       '....jouw code hier
    end if
End Sub
 
Dank je wel Harry, ik begrijp jouw reactie dat het koffiedik kijken is. Misschien dat de volgende code jou helpt om het probleem te begrijpen.

Code: 
If Range("C166") = "" Then Range("C166") = "Debiteuren"
If Range("C182") = "" Then Range("C182") = "Crediteuren"

If [Naambank] <> "" And Range("C167") <> [Naambank] Then Range("C167") = [Naambank]
If [Naambank] <> "" And Range("C183") <> [Naambank] Then Range("C183") = [Naambank]

If [Contant] <> "" And Range("C168") <> [Contant] Then Range("C168") = [Contant]
If [Contant] <> "" And Range("C184") <> [Contant] Then Range("C184") = [Contant]

If [Naambank2] <> "" And Range("C169") <> [Naambank2] Then Range("C169") = [Naambank2]
If [Naambank2] <> "" And Range("C185") <> [Naambank2] Then Range("C185") = [Naambank2]

If IsError(Application.Match("Privé " & Range("R3"), Range("C168:C180"), 0)) And IsError(Application.Match(Range("C180"), Range("C167:C179"), 0)) Then If Range("C180") = "" Then Range("C180") = "Privé " & Range("R3")
If IsError(Application.Match("Privé " & Range("R3"), Range("C184:C198"), 0)) And IsError(Application.Match(Range("C198"), Range("C183:C197"), 0)) Then If Range("C198") = "" Then Range("C198") = "Privé " & Range("R3")

If IsError(Application.Match("Privé " & Range("R5"), Range("C168:C180"), 0)) And IsError(Application.Match(Range("C180"), Range("C167:C179"), 0)) Then If Range("C180") = "" And Range("R5") <> "" Then Range("C180") = "Privé " & Range("R5")
If IsError(Application.Match("Privé " & Range("R5"), Range("C184:C198"), 0)) And IsError(Application.Match(Range("C198"), Range("C183:C197"), 0)) Then If Range("C198") = "" And Range("R5") <> "" Then Range("C198") = "Privé " & Range("R5")

If IsError(Application.Match("Privé " & Range("R7"), Range("C168:C180"), 0)) And IsError(Application.Match(Range("C180"), Range("C168:C179"), 0)) Then If Range("C180") = "" And Range("R7") <> "" Then Range("C180") = "Privé " & Range("R7")
If IsError(Application.Match("Privé " & Range("R7"), Range("C184:C198"), 0)) And IsError(Application.Match(Range("C198"), Range("C183:C197"), 0)) Then If Range("C198") = "" And Range("R7") <> "" Then Range("C198") = "Privé " & Range("R7")

If IsError(Application.Match("Natura", Range("C168:C180"), 0)) And Range("C180") = "" And IsError(Application.Match(Range("C180"), Range("C167:C179"), 0)) Then Range("C180") = "Natura"
If IsError(Application.Match("Natura", Range("C184:C198"), 0)) And Range("C198") = "" And IsError(Application.Match(Range("C198"), Range("C184:C198"), 0)) Then Range("C198") = "Natura"

Bovenstaande wordt geactiveerd wanneer het vak volledig wordt gewist. Omdat de cellen door het wissen leeg komen te staan, wordt bovenstaande geactiveerd en heb ik precies dat staan wat er moet staan. Daarom denk ik dat hetgeen jij uit de hoge hoed kunt toveren ook zeker gaat werken.

Dus nog even resumerend. Wanneer je het voorbeeldbestand neemt, daar zie je dat in cel B naast Cel C waar ING staat leeg is (alleen de formule staat er nog in). Alleen in zo'n dergelijke situatie moet alles gewist worden waardoor bovenstaande code geactiveerd wordt en alle actuele zaken op de juiste plek komen te staan.

Ik begrijp dat het enorm lastig is omdat je niet over alle informatie beschikt en waardeer het des temeer dat je nog de moeite wilt nemen om dit probleem op te lossen. Wederom alvast heel erg bedankt.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan