Beste,
Onderstaande macro verwijdert mijn geselecteerde kolommen niet.
Wanneer ik via de VBA editor de macro nogmaals run verwijdert deze wel de kolommen.
Hoe kan dit, en hoe kan ik dit oplossen?
Onderstaande macro verwijdert mijn geselecteerde kolommen niet.
Wanneer ik via de VBA editor de macro nogmaals run verwijdert deze wel de kolommen.
Hoe kan dit, en hoe kan ik dit oplossen?
Code:
If MsgBox("Wilt u de actielijst genereren?", vbYesNo) = vbYes Then
'Copy Actielijst
Dim WS As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim cell As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
DoEvents
Application.DisplayAlerts = False
Sheets("Copy Actionlist").Delete
Application.DisplayAlerts = True
Set WSNew = Worksheets.Add
WSNew.Name = "Copy Actionlist"
Sheets("Copy Actionlist").Move After:=Sheets("Actionlist")
'Delete the sheet MyFilterResult if it exists
'On Error Resume Next
'Application.DisplayAlerts = False
'Sheets("Copy Actionlist").Delete
'Application.DisplayAlerts = True
'On Error GoTo 0
Sheets("Copy Actionlist").Select
Cells.Select
Selection.EntireColumn.Hidden = False
Columns("A:AD").Select
Selection.ClearContents
'Add a new worksheet to copy the filter results in
Sheets("Actionlist").Select
Range("A1:AB10001").Select
Selection.Copy
Sheets("Copy Actionlist").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths
Application.CutCopyMode = False
'Hyperlink toevoegen aan referentiekolom
Range("H2:H2001").Select
For Each cell In Intersect(Selection, _
Selection.SpecialCells(xlConstants, xlTextValues))
With Worksheets(1)
.Hyperlinks.Add anchor:=cell, _
Address:="http://www.test.nl/" + cell.Value, _
ScreenTip:=cell.Value, _
TextToDisplay:=cell.Value
End With
Next cell
'Overtollige kolommen verwijderen
Sheets("Copy Actionlist").Range("A1").Select
[COLOR="magenta"] Range("A:A,C:C,E:E,F:F,L:L,S:S,T:T,U:U,V:V,W:W,AB:AB").Delete[/COLOR]
Sheets("Reporting").Select
Else
End If
End Sub