Cellen verplaatsen naar 1 kolom

[HWV]

Beste,

In de bijlage een bestandje wat mijn vraag wat duidelijker zal maken.
Ik heb 4 kolomen waar tekst en getallen staan.
nu wil ik in de 5e kolom de tekst verzamelen.

1000 Product
1000 11000 Sub product
1000 11100 11110 Sub sub product
1000 11100 11110 11111 Sub sub sub product

Graag wil ik de tekseten in een kolom ernaast willen hebben.

Ik heb al geprobeerd met de als functie en met hulp kolomen een formule te maken.
Maar dan krijg ik niet het gewenste resultaat.

Aangezien dit een erg lange lijst is die wisseld is, zou ik dit in VBA willen maken, tevens kan ik dit dan meenemen in mijn conversie

Groet HWV

 

[Haije]

Samenvoegen

Beste HWV,

zet in H1:
=ALS(TYPE(A1)=2;A1;"")&ALS(TYPE(B1)=2;B1;"")&ALS(TYPE(C1)=2;C1;"")&ALS(TYPE(D1)=2;D1;"")&ALS(TYPE(E1)=2;E1;"")

en copieer die naar beneden

 

[HWV]

Stapje verder

Beste,

In het voorbeeld wat ik er bij heb gedaan is het mij gelukt de cellen te koppelen , maar dit met formule`s

Kolom 6:

=AANTAL.LEGE.CELLEN(A1:E1)

Kolom 7:

=ALS(F1=3;B1;"")

Kolom 8:

=ALS(F1=2;C1;"")

Kolom 9:

=ALS(F1=1;D1;"")

Kolom 10 :

=ALS(F1=0;E1;"")

Kolom 11:

=TEKST.SAMENVOEGEN(G1;H1;I1;J1)

Op deze manier bereik ik mijn resultaat wel , maar krijg ik het nog niet verwerkt in mijn conversie, die is gemaakt in VBA.

Mijn voorkeur gaat uit naar VBA, graag zou ik hier ondersteuning in willen krijgen

groet HWV

 

[WHER]

Geen VBA zoals gevraagd (helaas) maar een eenvoudige formule.

 

[DCWDPT]

Je bent met de Als formule wel op de goede weg. Ik heb het met deze gedaan:

=ALS(B13="product";B13;ALS(C13="Sub product";C13;ALS(D13="Sub sub product";D13;(ALS(E13="Sub sub sub product";E13;"")))))

En dat werkt goed voor zover ik het zie.

:thumb:

 

[Haije]

Samenvoegen

in VBA (waarbij je eerst H1 selecteerd):

Sub Macro21()
'
' Macro21 Macro
' De macro is opgenomen op 09-07-2009 door hschuurm.
'
'
Range("H1").Select
ActiveCell.FormulaR1C1 = _
"=IF(TYPE(R[-1]C[-7])=2,R[-1]C[-7],"""")&IF(TYPE(R[-1]C[-6])=2,R[-1]C[-6],"""")&IF(TYPE(R[-1]C[-5])=2,R[-1]C[-5],"""")&IF(TYPE(R[-1]C[-4])=2,R[-1]C[-4],"""")&IF(TYPE(R[-1]C[-3])=2,R[-1]C[-3],"""")"
End Sub

 

[HWV]

Niet helemaal

Alvast allemaal bedankt voor de inzet die jullie hebben gedaan.


De code van Haije en van Wher doen het goed, enkel die van DCWDPT kan ik niet gebruiken dit ivm dat het een lange lijst is met verschillende producten.

Wat ik dus ook in mijn vraagstelling ben vergeten is dat het verplaatst moet worden zodat ik dus de teksten onder elkaar krijg en dat deze niet meer in de kolmen staan waar ook getallen staan.

Ik hoop dat ik nu iets duidelijker ben geweest in mijn vraagstelling.

groet HWV

 

[Haije]

als je dit opneemt in VBA, en je bouwt er zelf een loopje omheen, dan moet je er zijn (hoop ik).

Sub Macro21()
'
' Macro21 Macro
' De macro is opgenomen op 09-07-2009 door hschuurm.
'
'
ActiveCell.FormulaR1C1 = _
"=IF(TYPE(RC[-7])=2,RC[-7],"""")&IF(TYPE(RC[-6])=2,RC[-6],"""")&IF(TYPE(RC[-5])=2,RC[-5],"""")&IF(TYPE(RC[-4])=2,RC[-4],"""")&IF(TYPE(RC[-3])=2,RC[-3],"""")"
ActiveCell.Offset(1, 0).Range("A1").Select
End Sub

 

[Haije]

Samenvoegen

net geleerd dat het eigenlijk zo moet:

Sub Macro21()
'
' Macro21 Macro
' De macro is opgenomen op 09-07-2009 door hschuurm.
'
'
    ActiveCell.FormulaR1C1 = _
        "=IF(TYPE(RC[-7])=2,RC[-7],"""")&IF(TYPE(RC[-6])=2,RC[-6],"""")&IF(TYPE(RC[-5])=2,RC[-5],"""")&IF(TYPE(RC[-4])=2,RC[-4],"""")&IF(TYPE(RC[-3])=2,RC[-3],"""")"
    ActiveCell.Offset(1, 0).Range("A1").Select
End Sub

Wigi bedankt!

 

[snb]

Sub tst()
  sq = [A1].CurrentRegion
  st = [A1].CurrentRegion.Offset(, 6).Resize(, 1)
  For j = UBound(sq, 2) To 1 Step -1
    For jj = 1 To UBound(sq)
      If st(jj, 1) = "" Then st(jj, 1) = sq(jj, j)
    Next
  Next
  [G1].Resize(UBound(st)) = st
End Sub

en als je vindt dat het met een werkblad formule moet:

Sub tst2()
  [G1].formulalocal="=KIEZEN(ALS(E1<>"";4;ALS(D1<>"";3;ALS(C1<>"";2;ALS(B1<>"";1))));B1;C1;D1;E1)"
  [A1].usedrange.offset(,6).resize(,1).filldown
End Sub

 

[HWV]

gaat nog niet helemaal goed

Bedankt allen voor de reactie`s.

Die van SNB komt erg veel in de richting.

Hij doet de eerste alinia, maar dan komt er een lege cel en daar stopt de code.
De lege cel herhaalt zich vele malen tot aan regel 1500.

Zoals in mijn vorige topic gaf ik aan dat ik vergeten was om te zeggen dat de gegevens verplaats dienen te worden ipv gekopieerd.
Is dat een mogelijkhieid ?

aanvulling

Ik heb de lege regels weggehaald met de volgende code;

    Dim lRij As Long
    
    For l = Range("A" & Rows.count).End(xlUp).Row To 1 Step -1
        
        If Range("A" & l).Value = "" Or Left(Range("A" & l).Value, 1) = "-" Then
        
            Rows(l).Delete
        
        End If
    
    Next

Nu draai uw code ( SNB ) wel door tot aan onder.
Enkel nu zit ik er nog mee dat vanwaar ik ze heb gekopieerd dat deze eigelijk verwijder dienen te worden.

Groet HWV

 

[snb]

Sub tst()
[COLOR="Blue"]  usedrange.columns(1).specialcells(xlcelltypeBlanks).entirerow.delete[/COLOR]
  sq = [A1].CurrentRegion
  st = [A1].CurrentRegion.Offset(, 6).Resize(, 1)
  For j = UBound(sq, 2) To 1 Step -1
    For jj = 1 To UBound(sq)
      If st(jj, 1) = "" Then st(jj, 1) = sq(jj, j)
    Next
  Next
  [G1].Resize(UBound(st)) = st
End Sub

De verplaatsingsbedoeling is mij niet duidelijk.

Overigens ben ik benieuwd of je mijn code begrijpt.

 

[HWV]

Begrijpen niet echt

  UsedRange.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Object vereist geef hij aan op deze regel. en stopt

Buiten deze fout is het moeilijk om deze formule te begrijpen, ik probeer een end te komen met de help functie.

      If st(jj, 1) = "" Then st(jj, 1) = sq(jj, j)

Hier wordt er gedifineer of er een lege cel is, maar daar blijf het voor mij bij.

In de bijlage mijn uiteindelijke doel, ik hoop dat ik daar duidelijk genoeg in ben , om tot het gewenste resultaat te komen

Groet HWV

 

[HWV]

Probleem van fout opgelost

Sub test()
  Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  sq = [A1].CurrentRegion
  st = [A1].CurrentRegion.Offset(, 6).Resize(, 1)
  For j = UBound(sq, 2) To 1 Step -1
    For jj = 1 To UBound(sq)
      If st(jj, 1) = "" Then st(jj, 1) = sq(jj, j)
    Next
  Next
  [G1].Resize(UBound(st)) = st
End Sub

Code is aangepast en doet het nu goed, ipv :

UsedRange.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

heb ik gebruikt :

Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Kunt u me wel verder helpen met mijn vraag , als ik nu duidelijker ben geweest.

groet HWV

 

[snb]

Als je kijkt waar mijn code de produktnamen zet kun je je eigen vraag oplossen.

 

[HWV]

snb

Ik probeer nu al eigenlijk heel de tijd uw code te ontleden.
Maar vind het erg moeilijk om het te begrijpen nu deze zo uit de lucht val.
Ik ben blij met de hulp die ik krijg hiermee, en doe echt mijn best om het te snappen.
Ik zie wat hij doet , maar om het uit te leggen is moeilijk.

Groet HWV

PS,

Kom er echt niet verder mee, wil het graag begrijpen.
Maar met korte antwoorden, kom ik niet verder.
mischien wil u de moeite nemen dit aan mij uit te leggen.
Bijvoorbaat mijn grote dank.

Henk

 

[HWV]

Beste,

Ik wam er niet uit dus vandaar ben ik het op een andere manier gaan zoeken.
Ik heb met de als functie maar een macro opgenomen en die doet nu wat ik wil.
Het is een ander insteek geworden, eerst de code van SNB laten lopen dan kijken via de als functie of de cel gelijk is aan de tekst.

In het voorbeeld kan je kijken wat de code doet.

Sub test()
  Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  sq = [A1].CurrentRegion
  st = [A1].CurrentRegion.Offset(, 6).Resize(, 1)
  For j = UBound(sq, 2) To 1 Step -1
    For jj = 1 To UBound(sq)
      If st(jj, 1) = "" Then st(jj, 1) = sq(jj, j)
    Next
  Next
  [J1].Resize(UBound(st)) = st

    Range("F1").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-5]=RC[4],"""",RC[-5])"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-5]=RC[3],"""",RC[-5])"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-5]=RC[2],"""",RC[-5])"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-5]=RC[1],"""",RC[-5])"
    Range("F1:I1").Select
    Selection.Copy
    Range("F2:I1500").Select
    ActiveSheet.Paste
    Columns("F:J").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Copy
    Range("A1").Select
    ActiveSheet.Paste
    Columns("F:J").Delete
    Columns("A:E").EntireColumn.AutoFit
End Sub

Ik de oplossing op deze manier gevonden, maar dit zal ongetwijfeld korter kunnen.

Als je kijkt waar mijn code de produktnamen zet kun je je eigen vraag oplossen.

Ik heb gekeken met welk stuk van de formule de product namen worden gezet :

  [J1].Resize(UBound(st)) = st

Maar hier kwam ik niet in uit dus vandaar deze oplossing

groet HWV

 

[bandito bob]

Het kan ook met volgende simpele formule voor cel G1:

=ALS(A1="";"";VERSCHUIVING(A1;;AANTALARG(A1:E1)-1))

Vervolgens te kopieren naar beneden.

Deze formule kan je natuurlijk ook in een macro-tje gieten.

 

[HWV]

Reactie

Beste Bandito Bob,

Bedankt voor jou reactie.
Mooie formule, en weer wat erbij geleerd.
Ik kan deze inderdaad in een macro zetten, maar daar heb ik nu de optie van SNB staan.
Ik zocht enkel nog een manier om de tekst die we hebben verplaatst om deze nu te wissen.
Ik heb deze nu met een macro opgenomen met de bekende ALS formule.
Het werkt maar om het goed te doen is er eigenlijk een goede VBA formule nodig.

Groet HWV