Aantal kolommen automatisch aanpassen d.m.v macro

[surfingmaster]

Hallo Dames/ Heren,

Ik heb een spreadsheat gemaakt. Ik wil daarvoor een macro maken die automatisch kolommen toevoegd of verwijdert. Aan de hand van formule staat er in een cel hoeveel kolommen er vanaf kolom 17 bij moeten.
In de kolommen die toegevoegd worden, moeten dan de formules gekopieerd worden uit kolom (P).

Ik heb al het een en ander geprobeerd. Die macro kopiert kolom P en voegt er 1 in voor de laatste kolom. De laatste kolom moet namelijk de laatse blijven, want daar staan andere formules in.

Dit heb ik tot nu toe:

Sub KopierenKolom()
'
' KopierenKolom Macro
'

'
    Columns("P:P").Select
    Selection.Copy
    
    Dim Col As Integer
Col = ActiveSheet.UsedRange.Columns.Count
Cells(1, Col - 2).Activate
With ActiveCell
.EntireColumn.Insert
End With


End Sub

 

[Jack Nouws]

Hallo,

Kijk eens of je hier wat mee kunt.
In cel A1 kun je het aantal in te voegen kolommen invullen.

Sub tst()
  Columns(UsedRange.Columns.Count - 1).Resize(, [A1]).Insert
End Sub

Met vr gr
Jack

 

[surfingmaster]

Bedankt Jack,

ik heb de code geprobeerd, maar die code werkt niet bij mij. Ik gebruik excel 2007. Maakt dat misschien wat uit?

 

[Wigi]

Dit lijkt me dichter bij een oplossing te zitten:

Sub tst()
  Columns(16).Copy
  Cells(1, 17).Resize(, [A1]).Insert
  Application.CutCopyMode = False
End Sub

 

[surfingmaster]

Het lijkt er wel op, maar hij moet alleen de rij invoegen voor de twee na laatse kolom, want anders kloppen mijn formules niet meer. Hij plakt ze nu na de gekopieerde rij. Maar wel bedankt voor tot zover.

 

[snb]

sub of()
  columns(17+cells(1,17))=columns(17)
  columns(16).resize(,cells(1,17))=columns(16)
End Sub

Verwar je soms rijen(horizontaal) met kolommen (vertikaal) ?

 

[surfingmaster]

Nee, want als ik de formule die ik tot nu toe had gebruik om 1 kolom toe te voegen, klopt alles nog. De reden waarom het niet goed gaat met de gegeven macro is dat ik twee kolommen met precies dezelfde formules en celverwijzigingen krijgen. Ik moet voorelkaar zien te krijgen dat ik de colom helemaal aan het eind in vul. Zodat hij verwijst naar de kolom voor hem. Kolom 2 verwijst naar kolom 1. Kolom 3 naar 2 enz.

Sub KopierenKolom()
'
' KopierenKolom Macro
'

'
ActiveSheet.Unprotect Password:=""
Application.ScreenUpdating = False

Columns("P").Select
Selection.Copy

Dim Col As Integer
Col = ActiveSheet.UsedRange.Columns.Count
Cells(1, Col - 2).Activate
With ActiveCell
.EntireColumn.Insert
End With
Application.ScreenUpdating = True
ActiveSheet.Protect Password:=""


End Sub

Gr, Erwin

 

[snb]

sub of()
  columns(17+[A1])=columns(17)
  columns(16).resize(,[A1]).fillright
End Sub

en om hem robuuster te maken:

sub of()
  With sheets(1).usedrange
    x=.columns.count
    .columns(x+[A1])=.columns(x)
    .columns(x-1).resize(,[A1]).fillright
  End with
End Sub

Plaatsing van een voorbeeldbestand kan ook helemaal geen kwaad.

 

[surfingmaster]

hierbij stuur ik een voorbeeld van mijn bestand. De macro die ik nu gebruik staat hieronder, maar wil deze aanpassen zodat hij dit zelf doet aan de hand van het aantal berekende kolommen die er zouden moeten komen.
Ik wil daarvoor een macro maken die automatisch kolommen toevoegd of verwijdert. Aan de hand van formule staat er in cel A1 hoeveel kolommen er vanaf kolom L bij moeten of verwijdert moeten worden.
In de kolommen die toegevoegd worden, moeten dan de formules gekopieerd worden uit kolom (M). En de kolommen moeten dan voor de 2 na laatste kolom ingevoegd worden.


Sub KopierenKolom()
'
' KopierenKolom Macro
'

'
ActiveSheet.Unprotect Password:=""
Application.ScreenUpdating = False

Columns("M:M").Select
Selection.Copy

Dim Col As Integer
Col = ActiveSheet.UsedRange.Columns.Count
Cells(1, Col - 2).Activate
With ActiveCell
.EntireColumn.Insert
End With
Application.ScreenUpdating = True
ActiveSheet.Protect Password:=""


End Sub

 

[Warme bakkertje]

Met deze kom je mi al iets verder

Sub KopierenKolom()
Application.ScreenUpdating = False
With Sheets("Blad1")
    .Unprotect Password:=""
    For i = 1 To [A1] + 13 - .UsedRange.Columns.Count
        .Columns(13).Copy
        .Cells(1, .UsedRange.Columns.Count - 1).Insert
    Next
    .Protect Password:=""
End With
Application.ScreenUpdating = True
End Sub

 

[surfingmaster]

Hoi Rudy,

bedankt voor je reactie. Met een kleine aanpassing werkt de macro nu uitstekend.

Erwin

 

[Warme bakkertje]

:thumb:
Zet je de vraag dan nog even op opgelost

 

[surfingmaster]

Is opgelost