• 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.
H

HJ1

Gebruiker
Lid geworden
3 sep 2021
Berichten
73
Ik heb een hele lijst met Functies en hele lijst met Toegang tot opties, hier heb ik even een klein voorbeeld toegevoegd ipv de hele lijst.

Zie bijlage
Huidige input: LINKS
Wenselijke output: RECHTS

Na het uitvoeren van de macro (vba) zijn de volgende acties wenselijk:
1) Indien er een kruisje staat moet hier de Toegang code (rij A)
2) Alle waarden moeten opgeschoven worden en aansluitend na kolom B.
 

Bijlagen

  • 02 stam export.xlsx
    10,1 KB · Weergaven: 28
Je voorbeeld bestand bevat geen macro's.
 
Verzorgt NCOI geen Excel-cursussen in Drachten ?

In L6:
PHP: 
=INDEX($C$1:$G$1;MATCH("X";C6:G6;0))
In M6:
PHP: 
 =IFERROR(INDEX($C$1:$G$1;;MATCH("X";OFFSET(C6:G6;;MATCH("X";C6:G6;0));0)+MATCH("X";C6:G6;0));"")
 
Laatst bewerkt:
Heb ook even een xlsm toegevoegd.
 

Bijlagen

  • 02 stam export 2.xlsm
    18,3 KB · Weergaven: 16
Heb je de formules al toegepast ?
 
daar ben ik dus naar op zoek hoe je dit via een formule of code kunt omzetten van X naar de code + daarnaast lege cellen verwijderen op een rij.
 
Laatst bewerkt:
HJ1,

in deze bijlage staan de formules van SNB zoals ze in het NL zijn
 

Bijlagen

  • 02 stam export 2 plus formules SNB .xlsm
    17,5 KB · Weergaven: 27
Iets geavanceerder; in L6 de matrix-formule:

PHP: 
=IFERROR(INDEX($C$1:$G$1;;SMALL(IF($C6:$G6="X";COLUMN($A1:$E1));COLUMN(A1)));"")

doortrekken naar rij 16, en kolom P
 
Helaas worden de lege cellen niet verwijderd, ondanks dat de cel leeg is ziet Excel toch nog een kenmerk dat het veld niet verwijderd wordt.

Ik heb namelijk een stamdata werkklad "Invulblad".
1) Mijn eerste actie die ik doe is een kopie maken van mijn Invulblad en deze plak ik in mijn werkblad "Export".
2) Via VBA vul ik cel B1 vul met deze formule

=ALS(Invulblad!C6="X";Invulblad!C$1;"")
ActiveCell.FormulaR1C1 = "=IF(Invulblad!RC=""X"",Invulblad!R1C,"""")"

3) Deze kopieer ik na alle velden (in dit geval B1 t/m AT39 (ik wil eigenlijk met een variabele code doen maar die krijg ik niet werkende (de kolom en laatst cel wil niet)

Alle velden zijn nu gevuld met de gewenste code.
4) Daarna wil ik alle formules uit het werkblad halen zodat alle lege cellen ook worden herkend, dit dacht ik te doen door Kopiëren -> plakken speciaal "als waarden".
5) Selecteren lege cellen, wanneer ik alle cellen selecteer en F5 (ga naar) > speciaal > lege waarden ; dan worden toch alle lege cellen niet geselecteerd...en kan ik ze dus ook niet verwijderen.

Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlToLeft
 

Bijlagen

  • 02 Excel Versie 09.xlsm
    46,2 KB · Weergaven: 23
Je kan alle formules naar waarden converteren als volgt:
Code: 
For Each cl In Range(ActiveSheet.UsedRange.Address).SpecialCells(xlCellTypeFormulas)
   cl.Formula = cl.Value
Next cl

Dan werkt je F5 actie wel zoals gewenst.
Geen idee wat er dan in je voorbeeld document nog met E1 aan de hand is.
 
Laatst bewerkt:
Kan toch in 1 keer met VBA?

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
    If Len(c00) Then
      d(ar(j, 2)) = ar(j, 2) & "|" & c00
      c00 = ""
    End If
  Next j
  
  With Sheets("Export")
    .Cells.Clear
    .Cells(1).Resize(d.Count) = Application.Transpose(d.items)
    .Columns(1).TextToColumns .Cells(1), xlDelimited, , False, False, False, False, False, True, "|"
  End With
End Sub
 
@VenA,
Dit werkt inderdaad geniaal! Scheelt heel wat scripting :-D

Kun je misschien het een en ander toelichten zodat ik ook een beetje weet wat wat doet...en dat ik het tzt vaker kan gaan toepassen.
Thankx!
 
Een snellere methode dan texttocolumns.
Code: 
Sub hsv()
  sv = Sheets("Invulblad").UsedRange
  ReDim b(UBound(sv) + 1)
  Set d = CreateObject("Scripting.Dictionary")
  For j = 6 To UBound(sv)
    For jj = 3 To UBound(sv, 2)
      If LCase(sv(j, jj)) = "x" Then
            a = d(sv(j, 2))
              If IsEmpty(a) Then a = b
                 a(0) = sv(j, 2)
                 a(UBound(a)) = a(UBound(a)) + 1
                 a(a(UBound(a))) = sv(1, jj)
            d(sv(j, 2)) = a
           If x < a(UBound(a)) Then x = a(UBound(a))
          End If
        Next jj
     Next j
  With Sheets("Export")
    .Cells.Clear
    .Cells(1).Resize(d.Count, x + 1) = Application.Index(d.items, 0)
  End With
End Sub
 
ReDim b(UBound(sv, 2) + 1). Maar altijd leuk de combinatie van een dictionary met een array:thumb:
 
Juist, een foutje met grote gevolgen.
Hierbij de aangepaste versie (zonder de x constructie)

Code: 
Sub hsv()
  sv = Sheets("Invulblad").UsedRange
  ReDim b(UBound(sv, 2) + 1)
  Set d = CreateObject("Scripting.Dictionary")
  For j = 6 To UBound(sv)
    For jj = 3 To UBound(sv, 2)
      If LCase(sv(j, jj)) = "x" Then
           a = d(sv(j, 2))
              If IsEmpty(a) Then a = b
                 a(0) = sv(j, 2)
                 a(UBound(a)) = a(UBound(a)) + 1
                 a(a(UBound(a))) = sv(1, jj)
           d(sv(j, 2)) = a
          End If
        Next jj
     Next j
   With Sheets("Export")
    .Cells.Clear
    .Cells(1).Resize(d.Count, UBound(sv, 2) - 1) = Application.Index(d.items, 0)
  End With
End Sub
 
Code: 
Sub M_snb()
  Application.ScreenUpdating = False

  sn = Blad1.Range("C1:Q1")
  For j = 1 To UBound(sn, 2)
    Blad1.Columns(2 + j).Replace "X", sn(1, j)
  Next

  Blad1.Cells(6, 2).CurrentRegion.Offset(, 1).Resize(, UBound(sn, 2) + 1).SpecialCells(4).Delete -4159
End Sub
 
Laatst bewerkt:
Heb toch nog een kleine wens, nu worden alle cellen mooi opgeschoven maar eigenlijk zou ik deze cellen per rij in 1 cel willen hebben.
Cel A1: Z-ADM01, AB10, AB13, etc.
Cel A2: Z-ADM04, BB10, CC02, EE05, etc.


Deze code beviel heb ik nu toegepast
Code: 
Sub export_functie_groepen()
 sv = Sheets("Invulblad").UsedRange
  ReDim b(UBound(sv, 2) + 1)
  Set d = CreateObject("Scripting.Dictionary")
  For j = 6 To UBound(sv)
    For jj = 3 To UBound(sv, 2)
      If LCase(sv(j, jj)) = "x" Then
           a = d(sv(j, 2))
              If IsEmpty(a) Then a = b
                 a(0) = sv(j, 2)
                 a(UBound(a)) = a(UBound(a)) + 1
                 a(a(UBound(a))) = sv(1, jj)
           d(sv(j, 2)) = a
          End If
        Next jj
     Next j
   With Sheets("Export")
    .Cells.Clear
    .Cells(1).Resize(d.Count, UBound(sv, 2) - 1) = Application.Index(d.items, 0)
  End With
End Sub
 
Als je Excel 365 hebt dan kan het eenvoudig met deze formule
PHP: 
=IF(Invulblad!B6="";"";Invulblad!B6&", "&TEXTJOIN(", ";;IF(Invulblad!C6:Q6="x";Invulblad!$C$1:$Q$1;"")))
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan