• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

omzetten naar waarde en opschuiven

Status
Niet open voor verdere reacties.
VenA,
Dan krijg ik het wel mooi in 1 cel alleen wel steeds de zelfde waarde (de eerste waarde)

PHP: 
=ALS(Invulblad!B6="";"";Invulblad!B6&", "&TEKST.SAMENVOEGEN(", ";;ALS(Invulblad!C6:Q6="x";Invulblad!$C$1:$Q$1;"")))
 
Ik niet. Heb je automatisch berekenen uit staan?
 

Bijlagen

  • 02 Excel Versie 09 (1).xlsm
    24,1 KB · Weergaven: 17
Textjoin is vertaald in formulevorm geen Tekst.Samenvoegen.
Het zal iets van Tekst.combineren zijn.
 
De formule in de code kunnen verwerken.
Alleen wanneer er maar 1 waarde is dan komt er een overbodige komma (bij meerdere waarden gaat dat wel goed)


Code: 
Sub export_functie_groepen()
With Sheets("Export")
    .Cells.Clear
    
Sheets("Invulblad").Select
Range("B1").Select
Range("B1000").End(xlUp).Offset(0, 0).Select
laatste = ActiveCell.Row

Sheets("Export").Select
Range("A1").Select

For i = 1 To laatste + 1

    ActiveCell.Formula2R1C1 = _
        "=IF(Invulblad!R[5]C[1]="""","""",Invulblad!R[5]C[1]&"", ""&TEXTJOIN("", "",,IF(Invulblad!R[5]C[2]:R[5]C[16]=""x"",Invulblad!R1C3:R1C17,"""")))"


ActiveCell.Offset(1, 0).Select
Next i

Columns(1).SpecialCells(xlCellTypeBlanks).Delete

End With
End Sub

Vervolgens wil ik de lege regels verwijderen maar waarom worden deze niet herkend als "lege regel"?
Hierdoor verdwijnen ze ook niet met:

Code: 
Columns(1).SpecialCells(xlCellTypeBlanks).Delete
 
Als er een formule in een cel staat zal de cel dan leeg zijn? Waarom heb je de eerder geplaatste codes niet een beetje aangepast?


Code: 
Sub VenA()
  ar = Sheets("Invulblad").UsedRange
  Set d = CreateObject("Scripting.Dictionary")
  For j = 6 To UBound(ar)
    For jj = 3 To UBound(ar, 2)
      If LCase(ar(j, jj)) = "x" Then c00 = c00 & "," & ar(1, jj)
    Next jj
      d(ar(j, 2)) = ar(j, 2) & IIf(Len(c00), ", " & Mid(c00, 2), "")
      c00 = ""
  Next j
  
  With Sheets("Export")
    .Cells.Clear
    .Cells(1).Resize(d.Count) = Application.Transpose(d.items)
  End With
End Sub
 
De eerste lege regel blijft er nog wel tussen staan, de overige lege regels delete ie wel.
Hoe bepaal je dan dat de lege regel verwijderd wordt?

Code: 
Sub VenA()
  ar = Sheets("Invulblad").UsedRange
  Set d = CreateObject("Scripting.Dictionary")
  For j = 6 To UBound(ar)
    For jj = 3 To UBound(ar, 2)
      If LCase(ar(j, jj)) = "x" Then c00 = c00 & ", " & ar(1, jj)
    Next jj
      d(ar(j, 2)) = ar(j, 2) & IIf(Len(c00), ", " & Mid(c00, 2), "")
      c00 = ""
  Next j
  
  With Sheets("Export")
    .Cells.Clear
    .Cells(1).Resize(d.Count) = Application.Transpose(d.items)
  End With
End Sub
 
Hiermee krijg ik het ook wel weg:
Code: 
    Columns("A:A").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
 
Welke eerste lege regel?

Select en Selection zijn overbodig.
Code: 
Columns(1).SpecialCells(4).EntireRow.Delete
 
Thanks, die is nog beter :thumb:
Nog een kleine wijziging doorgevoerd want zat toch nog een dubbele spatie in, die is er nu ook uit.

Code: 
Sub export_functie_groepen()
With Sheets("Export")
    .Cells.Clear
  End With

  ar = Sheets("Invulblad").UsedRange
  Set d = CreateObject("Scripting.Dictionary")
  For j = 6 To UBound(ar)
    For jj = 3 To UBound(ar, 2)
      If LCase(ar(j, jj)) = "x" Then c00 = c00 & ", " & ar(1, jj)
    Next jj
      d(ar(j, 2)) = ar(j, 2) & IIf(Len(c00), "," & Mid(c00, 2), "")
      c00 = ""
  Next j
  
  With Sheets("Export")
    .Cells.Clear
    .Cells(1).Resize(d.Count) = Application.Transpose(d.items)
  End With

'lege regels verwijderen
Sheets("Export").Select
Columns(1).SpecialCells(4).EntireRow.Delete

End Sub
 
Laatst bewerkt:
Code: 
Sub M_snb()
  sn = Sheets("Invulblad").UsedRange
  
  For j = 6 To UBound(sn)
      For jj = 3 To UBound(sn, 2)
        sn(j, jj) = Replace(sn(j, jj), "x", sn(1, jj), , , 1)
      Next
      sn(j - 5, 1) = Replace(Application.Trim(Join(Application.Index(sn, j))), " ", ", ")
  Next
  
  With Sheets("Export")
     .Cells.Clear
     .Cells(1).Resize(UBound(sn) - 5) = sn
  End With
End Sub
 
Heb nog een kleinen aanvulling.
Ik heb nu een samenvoeging van 3 velden die worden in 1 cel geplaatst maar eigenlijk wil ik de waarden nog in 3 cellen A, B en C

Het gaat om dit stukje wat nu in 1 cel komt maar dus naar 3 cellen moet:
Code: 
d(ar(j, 1)) = ar(j, 1) & "; " & ar(j, 2) & "; " & ar(j, 2) & IIf(Len(c00), "," & Mid(c00, 2), "")

Kolom A: ar(j, 1)
Kolom B: ar(j, 2)
Kolom C: ar(j, 2) & IIf(Len(c00), "," & Mid(c00, 2), "")


Code: 
ar = Sheets("Invulblad").UsedRange
  Set d = CreateObject("Scripting.Dictionary")
  For j = 6 To UBound(ar)
    For jj = 3 To UBound(ar, 2)
      If LCase(ar(j, jj)) = "x" Then c00 = c00 & ", " & ar(1, jj)
    Next jj
      d(ar(j, 1)) = ar(j, 1) & "; " & ar(j, 2) & "; " & ar(j, 2) & IIf(Len(c00), "," & Mid(c00, 2), "")
      c00 = ""
  Next j
  
  With Sheets("Export")
    .Cells.Clear
    .Cells(1).Resize(d.Count) = Application.Transpose(d.items)
  End With
 
Laatste versie ook even toegevoegd als bijlage.

Huidig:
Code: 
d(ar(j, 1)) = ar(j, 1) & "; " & ar(j, 2) & "; " & ar(j, 2) & IIf(Len(c00), "," & Mid(c00, 2), "")

Zoiets ook geprobeerd maar geeft ook niet de gewenste oplossing, dan zet ie het onder elkaar ipv de 3 velden naar elkaar in kolom A/B/C.
Code: 
d(ar(j, 1)) = ar(j, 1) 
d(ar(j, 2)) = ar(j, 2) 
d(ar(j, 3)) = ar(j, 2) & IIf(Len(c00), "," & Mid(c00, 2), "")
 

Bijlagen

  • 02 verdelen over de kolommen.xlsm
    25,7 KB · Weergaven: 12
Laatst bewerkt:
Al kunnen oplossen door 'Tekst naar kolommen' te gebruiken met scheidingsteken ;

Code: 
Sheets("Export").Select
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
Range("A1").Select
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan