D.m.v macro rijen verwijderen

[surfingmaster]

Beste dames en heren,

ik heb nu de macro die via een macro de benodigde aantal kolommen toevoegd:

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

Maar nu dacht ik deze om te bouwen die het aantal kolommen verwijderd, die ik niet nodig heb.

Die macro die ik er van had gemaakt is deze:

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

Deze macro werkt echter niet. De bedoeling is dat hij het aantal kolommen aanpast als het er teveel zijn. Daarbij mogen de laatste 3 kolommen niet verwijderd worden. De kolommen daarvoor moeten dus verwijderd worden, als er teveel kolommen zijn. Het aantal benodigde kolommen vanaf kolom m staat in cel A1

Ik heb een voorbeeldbestand ingevoegd

 

[Warme bakkertje]

Test deze eens uit

Sub KolommenDelete()
Application.ScreenUpdating = False
With Sheets("Omzet")
 .Unprotect Password:=""
 For i = 1 To .UsedRange.Columns.Count - [A1 + 13]
.Cells(1, .UsedRange.Columns.Count - 3).EntireColumn.Delete
 Next
 .Protect Password:=""
End With
Application.ScreenUpdating = True
End Sub

 

[surfingmaster]

bedankt Rudi. Je macro werkt.

Ik heb nu twee macro's samengevoegd, zodat het aantal kolommen aangepast wordt. Als er teveel kolommen zijn worden ze verwijderd, als er te weinig kolommen zijn worden ze toegevoegd:

Sub KolommenAanpassen()
Application.ScreenUpdating = False
Dim Col As Integer
Col = ActiveSheet.UsedRange.Columns.Count
With Sheets("Omzet")
If Col > [A1] + 13 Then
.Unprotect Password:=""
 For i = 1 To .UsedRange.Columns.Count - [A1 + 13]
.Cells(1, .UsedRange.Columns.Count - 4).EntireColumn.Delete
Next
.Protect Password:=""
End If
If Col < [A1] + 13 Then
.Unprotect Password:=""
For i = 1 To [A1] + 13 - .UsedRange.Columns.Count
.Columns(14).Copy
.Cells(1, .UsedRange.Columns.Count - 3).Insert
Next
.Protect Password:=""
Else
ActiveSheet.Protect Password:=""
End If
Application.ScreenUpdating = True
End With
End Sub

Echter wilde ik hier nog een macro aan toevoegen, maar dan werkt hij niet meer. De volgende macro wil ik toevoegen. Die macro moet worden uitgevoerd na de bovenstaande macro.

Sub FitColumns()
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:=""
With ActiveSheet.UsedRange
For Each Col In .Columns
If Col.Column > 14 Then
Col.AutoFit
Col.ColumnWidth = WorksheetFunction.Max(Col.ColumnWidth, 6.57)
End If
Next
.Columns(.Columns.Count - 3).Hidden = True
End With
ActiveSheet.Protect Password:=""
Application.ScreenUpdating = True
End Sub

De macro moet na het uivoeren van de bovenste macro de breedte aanpassen van de kolommen. Ik wil hier één macro van maken maar dat lukt mij niet. Hoop dat iemand mij kan helpen.

Groeten,
Erwin

 

[Warme bakkertje]

Test 'm zo eens uit

Sub KolommenAanpassen()
Application.ScreenUpdating = False
Dim Col As Integer
Col = ActiveSheet.UsedRange.Columns.Count
With Sheets("Blad1")
If Col > [A1] + 13 Then
.Unprotect Password:=""
 For i = 1 To .UsedRange.Columns.Count - [A1 + 13]
.Cells(1, .UsedRange.Columns.Count - 4).EntireColumn.Delete
Next
[COLOR="red"]tst[/COLOR]
.Protect Password:=""
End If
If Col < [A1] + 13 Then
.Unprotect Password:=""
For i = 1 To [A1] + 13 - .UsedRange.Columns.Count
.Columns(14).Copy
.Cells(1, .UsedRange.Columns.Count - 3).Insert
Next
[COLOR="red"]tst[/COLOR]
.Protect Password:=""
Else
ActiveSheet.Protect Password:=""
End If
Application.ScreenUpdating = True
End With
End Sub

Sub tst()
With ActiveSheet.UsedRange
For i = 14 To .Columns.Count
    With .Columns(i)
        .AutoFit
        .ColumnWidth = WorksheetFunction.Max(.ColumnWidth, 6.57)
    End With
Next
End With
End Sub

 

[surfingmaster]

Bedankt Rudi, ik heb de macro iets aangepast en nu werkt hij uitstekend.

Sub KolommenAanpassen()
Application.ScreenUpdating = False
Dim Col As Integer
Col = ActiveSheet.UsedRange.Columns.Count
With Sheets("Omzet")
If Col > [A1] + 13 Then
.Unprotect Password:=""
 For i = 1 To .UsedRange.Columns.Count - [A1 + 13]
.Cells(1, .UsedRange.Columns.Count - 4).EntireColumn.Delete
Next
tst
.Protect Password:=""
End If
If Col < [A1] + 13 Then
.Unprotect Password:=""
For i = 1 To [A1] + 13 - .UsedRange.Columns.Count
.Columns(14).Copy
.Cells(1, .UsedRange.Columns.Count - 3).Insert
Next
tst
.Protect Password:=""
Else
[COLOR="red"]ActiveSheet.Unprotect Password:=""[/COLOR]
tst
[COLOR="red"]ActiveSheet.Protect Password:=""[/COLOR]
End If
Application.ScreenUpdating = True
End With
End Sub

Sub tst()
With ActiveSheet.UsedRange
For i = 14 To .Columns.Count
    With .Columns(i)
        .AutoFit
        .ColumnWidth = WorksheetFunction.Max(.ColumnWidth, 6.57)
    End With
Next
[COLOR="red"].Columns(.Columns.Count - 3).Hidden = True[/COLOR]
End With
End Sub