Helpmij.nl
Helpmij.nl
Helpmij.nl

Quote

Pagina 2 van 2 EersteEerste 1 2
Weergeven resultaten 21 tot 33 van 33

Onderwerp: omzetten naar waarde en opschuiven

  1. #21
    Member
    Geregistreerd
    3 september 2021
    VenA,
    Dan krijg ik het wel mooi in 1 cel alleen wel steeds de zelfde waarde (de eerste waarde)

    PHP Code:
    1
    
    =ALS(Invulblad!B6="";"";Invulblad!B6&", "&TEKST.SAMENVOEGEN(", ";;ALS(Invulblad!C6:Q6="x";Invulblad!$C$1:$Q$1;"")))

  2. #22
    Giga Honourable Senior Member
    Geregistreerd
    2 maart 2013
    Ik niet. Heb je automatisch berekenen uit staan?
    Bijgevoegde bestanden Bijgevoegde bestanden
    Je kan een paard naar het water leiden, maar je kan het niet dwingen te drinken.

  3. #23
    Giga Honourable Senior Member
    Geregistreerd
    18 juli 2008
    Textjoin is vertaald in formulevorm geen Tekst.Samenvoegen.
    Het zal iets van Tekst.combineren zijn.
    ____________
    Met vriendelijke groet,
    Harry

    Lag nooit om de keuzes van dien vraauw, bist ter zulf aine van....
    (Grunnegs-Gronings)

  4. #24
    Member
    Geregistreerd
    3 september 2021
    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

  5. #25
    Giga Honourable Senior Member
    Geregistreerd
    2 maart 2013
    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
    Je kan een paard naar het water leiden, maar je kan het niet dwingen te drinken.

  6. #26
    Member
    Geregistreerd
    3 september 2021
    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

  7. #27
    Member
    Geregistreerd
    3 september 2021
    Hiermee krijg ik het ook wel weg:
    Code:
        Columns("A:A").Select
        Selection.SpecialCells(xlCellTypeBlanks).Select
        Selection.EntireRow.Delete

  8. #28
    Giga Honourable Senior Member
    Geregistreerd
    2 maart 2013
    Welke eerste lege regel?

    Select en Selection zijn overbodig.
    Code:
    Columns(1).SpecialCells(4).EntireRow.Delete
    Je kan een paard naar het water leiden, maar je kan het niet dwingen te drinken.

  9. #29
    Member
    Geregistreerd
    3 september 2021

    Talking

    Thanks, die is nog beter
    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 aangepast door HJ1 : 10 september 2021 om 15:37

  10. #30
    Giga Honourable Senior Member
    Verenigingslid
    snb's avatar
    Geregistreerd
    12 juni 2008
    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
    VBA voor smarties
    VBA is een taal die je moet leren met een grammatica- en een woordenboek.

    http://www.helpmij.nl/forum/announcement.php?f=5
    Plaats svp geen bestanden op andere sites; nadat het bestand daar verwijderd is wordt een forumdraad onbegrijpelijk voor anderen.

  11. #31
    Member
    Geregistreerd
    3 september 2021
    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

  12. #32
    Member
    Geregistreerd
    3 september 2021
    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), "")
    Bijgevoegde bestanden Bijgevoegde bestanden
    Laatst aangepast door HJ1 : 20 september 2021 om 14:01

  13. #33
    Member
    Geregistreerd
    3 september 2021
    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

Berichtenregels

  • U mag geen nieuwe vragen starten.
  • U mag niet reageren op berichten.
  • U mag geen bijlagen versturen.
  • U mag uw berichten niet bewerken.
  •  
Helpmij.nl
Helpmij.nl

Helpmij.nl

Regels
Help

Helpmij.nl en business

Partners
Sponsoren