gegevens uit rijen en kolommen verplaatsen

Status
Niet open voor verdere reacties.
W

W1llem

Gebruiker
Lid geworden
2 jun 2020
Berichten
20
Hallo beste forumhelpers,

De gegevens komen uit een csv bestand en zijn steeds 3 regels met een getal achter iedere regel waarbij de 1e regel de gegevens AA8I heeft. De steeds waarden van de steeds daaropvolgende 2 regels moeten in kommen daarachter komen.
Ik heb onderstaande maar het kan volgens mij veel sneller, vooral omdat deze verwerking zich in 8 sheets voordoet en de verwerking nu vrij veel tijd kost.
Liever niet met draaitabel (daar leer ik niets van:))

Code: 
' met formule de getallen van 2e en 3e regel van de 3 regels in de kolommen achter
' de 1e regel/1e kolom plaatsen
    range("I2").Select
        Selection.FormulaR1C1 = "=IF(R[1]C[-3]=""AB6I"",R[1]C[-1],"""")"
    range("J2").Select
        Selection.FormulaR1C1 = "=IF(R[2]C[-4]=""AC4I"",R[2]C[-2],"""")"

    
' de 3 getallen van de 1e regel kopieren naar steeds de volgende 1e van set van 3 regels
' eerst van 1 en daarna met steeds grotere blokken copy/paste
    
    range("I2:j2").Copy
    range("I5").Select
    ActiveSheet.Paste
    range("I2:j5").Copy
    range("I8").Select
    ActiveSheet.Paste
    range("I2:j11").Copy
    range("I14").Select
    ActiveSheet.Paste
    range("I2:j23").Copy
    range("I26").Select
    ActiveSheet.Paste
    range("I2:j47").Copy
    range("I50").Select
    ActiveSheet.Paste
    range("I2:J95").Copy
    range("I98 , I194, I290 , I386 , I482 , I578 , I674 , I770 , I866 , I962 , I1058").Select
    ActiveSheet.Paste

'
 ' de formules omzetten in waarden
    
    range("I:J").Copy
    range("I:J").Select
    Selection.PasteSpecial Paste:=xlPasteValues * 1, operation:=xlNone, skipblanks _
        :=False, Transpose:=False

Alvast dank
W1llem
 
Bij deze het bestand VenA en met inmiddels gewijzigde code
 

Bijlagen

  • Aandrijf_a.xlsm
    57,5 KB · Weergaven: 31
Als je al een bestaand blad hebt met de opmaak dan is alles verwijderen niet zo heel handig. Lijn bij voorkeur getallen/datums niet gecentreerd uit. Je ziet dan niet of het een getal of mogelijk een tekst is. daarnaast vind ik het hele centreren lelijk.

Code: 
Sub VenA()
  Dim a(1 To 10)
  Set d = CreateObject("Scripting.Dictionary")
  With sheets("CSVDATA")
    .Columns(1).TextToColumns .Cells(1), 1, , , 1
    ar = .Cells(1).CurrentRegion.Resize(, 8)
  End With
  For j = 2 To UBound(ar) Step 3
      For jj = 1 To UBound(ar, 2)
        a(jj) = ar(j, jj)
      Next jj
      a(9) = ar(j + 1, 8)
      a(10) = ar(j + 2, 8)
      d(d.Count + 1) = a
    Next j
    With sheets("ADRIJF")
      .Cells(1).CurrentRegion.Offset(1).ClearContents
      .Cells(2, 1).Resize(d.Count, 10) = Application.Index(d.items, 0)
    End With
End Sub
 
Dank je VenA.

Ik krijg de indruk dat het bij jou werkt maar helaas krijg ik in regel 2 al tegen een fout 429:
ActiveX-onderdeel kan object niet maken

Ik heb even op het web gekeken en het schijnt een probleem te zijn wat zich bij iMac voordoet.
Even verder zoeken dus.

Je tip over centreren begrijp ik en zal er 'voorzichter' mee omgaan.
 
Zonder CreateObject("Scripting.Dictionary") wordt het zoiets.

Code: 
Sub VenA()
  ReDim ar1(9, 0)
    With sheets("CSVDATA")
    .Columns(1).TextToColumns .Cells(1), 1, , , 1
    ar = .Cells(1).CurrentRegion.Resize(, 8)
  End With
  For j = 2 To UBound(ar) Step 3
      For jj = 1 To UBound(ar, 2)
        ar1(jj - 1, t) = ar(j, jj)
      Next jj
      ar1(8, t) = ar(j + 1, 8)
      ar1(9, t) = ar(j + 2, 8)
      t = t + 1
      ReDim Preserve ar1(9, t)
    Next j
    With sheets("ADRIJF")
      .Cells(1).CurrentRegion.Offset(1).ClearContents
      .Cells(2, 1).Resize(t, 10) = Application.Transpose(ar1)
    End With
End Sub
 
Bij regel ar1(9, t) = ar(j + 2, 8) krijg ik fout 9: subscript valt buiten het bereik.
Wanneer ik stap voor stap ga loopt het wel door maar zie ik nog steeds niets veranderen (afgezien van het verwijderen van de 1e = lege rij)
 
Waarschijnlijk
Code: 
.Columns(1).TextToColumns .Cells(1)
Aanpassen in
Code: 
.Columns(1).TextToColumns .Cells([COLOR="#FF0000"]2,1[/COLOR])

Of gewoon je gegevens in A1 laten beginnen en dan
Code: 
For j = [COLOR="#FF0000"]1[/COLOR] To UBound(ar) Step 3
 
Enig idee waarom ik in regel

.Columns(1).TextToColumns .Cells(2, 1), 1, , , 1

de foutmelding ongeldige doelverwijzing krijg?
 
Laatst bewerkt:
Schijnt toch lastiger te zijn dan voorzien ...

Ik heb het nu ook op een WIN10 pc getest en het enige effect is dat alle regels met de code AA8i (dus de eerste regel van de 3) naar blad ADRIJF gekopieerd worden. De overige gegevens worden niet meegenomen en de texttocolumns wordt ook niet uitgevoerd. Dit betreft de laatste versie.

De eerste versie geeft op de WIN10 pc bij regel a(10) = ar(j + 2, 8)
fout 9: subscript valt buiten het bereik.
 
Laatst bewerkt:
Zo dan?

Code: 
.Range("a2:a" & .Cells(Rows.Count, 1).End(xlUp).Row).TextToColumns .Cells(2, 1), 1, 0, 0, 0, 0, 1
 
Nu op mac subscript valt buiten het bereik bij regel ar1(9, t) = ar(j + 2, 8)

Op windows loopt het wel door maar is het resultaat alleen de volledige regels met AA8i naar ADRIJF zonder de texttocolumns uit te voeren.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan