Cellen in andere bladen automatisch 4 plekken naar links schuiven

Status
Niet open voor verdere reacties.
O

olaivo

Gebruiker
Lid geworden
24 mei 2017
Berichten
6
Ik wil aan een button een macro hangen die in andere bladen de waarden van 4 cellen 1 plek naar links kopieert.
Probleem is dat de cellen die ik wil kopieren niet overal op dezelfde rij staan, anders was ik er wel uit gekomen.
Ik denk dat er dus een soort zoekfunctie bij moet?

In het voorbeeld dat ik toegevoegd heb wil ik op de worksheet "button" een button maken met de macro die in de worksheets "data1" en "data2" enz. de waarden voor "toelaatbare grens" in kolom D, E, F en G een plek naar links kopieert. (Alleen de WAARDEN, want in het originele excel document staat een formule in kolom G die niet meegekopieert moet worden, maar wel de waarde 1 van moet opschuiven)

Ik moet op nog meer plekken cellen naar links verschuiven (heeft met jaarlijks opschuiven van data te maken) echter kom ik daar hopelijk zelf wel uit als ik een werkend scriptje heb voor dit stuk :)

Bij voorbaat dank!

EDIT: Er zijn ongeveer 50 bladen/worksheets ( allemaal andere namen, maar in VBA de namen Blad01 t/m Blad49 en ik weet niet of ik hier ook heen kan verwijzen) waarop die zelfde actie uitgevoerd moet worden dan. (Er is nog een blad91 t/m blad95 die niet meegenomen moet worden)
 

Bijlagen

  • Map1.xlsx
    15,2 KB · Weergaven: 39
Laatst bewerkt:
Probeer het scriptje maar eens
Code: 
Sub VenA()
Dim r As Range
For j = 1 To 2
  With Sheets("Data" & Format(j, "00")).Columns(1)
    Set r = .Find("Toelaatbare grens", , xlValues, xlWhole)
    If Not r Is Nothing Then
      c00 = r.Address
      Do
        r.Offset(, 2).Resize(, 4) = r.Offset(, 3).Resize(, 4).Value
        Set r = .FindNext(r)
      Loop While Not r Is Nothing And r.Address <> c00
    End If
  End With
Next j
End Sub
 
of
Code: 
Sub M_snb()
  With UsedRange.Columns(1)
    .AutoFilter 1, "toelaatbare grens"
    For Each it In .SpecialCells(12)
      If it = "Toelaatbare grens" Then it.Offset(, 1).Delete -4159
    Next
    .AutoFilter
  End With
End Sub
 
snb zei:
of
Code: 
Sub M_snb()
  With UsedRange.Columns(1)
    .AutoFilter 1, "toelaatbare grens"
    For Each it In .SpecialCells(12)
      If it = "Toelaatbare grens" Then it.Offset(, 1).Delete -4159
    Next
    .AutoFilter
  End With
End Sub
Klik om te vergroten...

Hier krijg ik een error op de regel "With UsedRange.Columns(1)"

Error is Object vereist... Als ik UsedRange aanpas naar bijvoorbeeld Sheets("Data") dan schuift hij alles eentje op inclusief de formules in de cel. Dat is niet de bedoeling helaas... Hij moet de waarde kopieren en die een cel naar links verplaatsen. Dan moet kolom B leeg blijven...

Weet niet of dat mogelijk is :$
 
Laatst bewerkt:
VenA zei:
Probeer het scriptje maar eens
Code: 
Sub VenA()
Dim r As Range
For j = 1 To 2
  With Sheets("Data" & Format(j, "00")).Columns(1)
    Set r = .Find("Toelaatbare grens", , xlValues, xlWhole)
    If Not r Is Nothing Then
      c00 = r.Address
      Do
        r.Offset(, 2).Resize(, 4) = r.Offset(, 3).Resize(, 4).Value
        Set r = .FindNext(r)
      Loop While Not r Is Nothing And r.Address <> c00
    End If
  End With
Next j
End Sub
Klik om te vergroten...

Fout 9: Het subscript valt buiten het bereik

Op regel "With Sheets ("Data")....."
 
Kijk eens even hoe jouw tabjes heten vast geen 'Data01' en 'Data02'.
 
Ik heb de macro opgenomen met de handeling die ik bedoel en dan krijg ik dit:
Code: 
Sub Kopierenenopschuiven()
'
' Kopierenenopschuiven Macro
'

'
    Sheets("data1").Select
    Range("D45:G45").Select
    Range("G45").Activate
    Selection.Copy
    Range("C45").Select
    ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
        IconFileName:=False
End Sub

Hierin wil ik eigenlijk ervoor zorgen dat die dat voor alle sheets doet en dat bij range het rijnummer niet vast staat, maar dat hij automatisch zoekt naar het rijnummer waar toelaatbare grens staat...
 
Dat is wat de code in #2 doet.
 

Bijlagen

  • Map1-2.xlsb
    22,9 KB · Weergaven: 28
VenA zei:
Dat is wat de code in #2 doet.
Klik om te vergroten...

Ah nu doet die inderdaad wat ik bedoel :) Nu heb ik nog 1 vraagje:
- Is het script zo aan te passen dat hij ook werkt als de sheets andere namen hebben... Dus bv. de sheets heten "Beek", "Belf X", "Belf Y"? (Eigenlijk moet het op alle sheets werken ongeacht de naam, en dan zijn er maar 3 sheets met een voorgedefinieerde naam die niet meegenomen hoeven te worden. Neem aan dat dat met een soort uitzondering ofzo kan?)

Plaatje ter verheldering van hoe de sheets heten... (Ik heb de objectnaam wel genummerd op volgorde btw, weet niet of daarheen te verwijzen is?)
Knipsel.PNG
 
Laatst bewerkt:
SVP niet citeren/quoten; gebruik de 'reageer op bericht' knop.
 
Om sheets uit te sluiten
bv
Code: 
Sub VenA()
Dim r As Range
For Each sh In Sheets
  If sh.Name <> "button" And sh.Name <> "Blad1" And sh.Name <> "Blad2" Then
    With sh.Columns(1)
      Set r = .Find("Toelaatbare grens", , xlValues, xlWhole)
      If Not r Is Nothing Then
        c00 = r.Address
        Do
          r.Offset(, 2).Resize(, 4) = r.Offset(, 3).Resize(, 4).Value
          Set r = .FindNext(r)
        Loop While Not r Is Nothing And r.Address <> c00
      End If
    End With
  End If
Next sh
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan