I have created code that works perfectly when I select 'run' from the vba screen, however when I assign this code to a button it fails to run in the same way and encounters errors.
The code I am using is as follows:
Code
Option Compare Text
Sub Create_Security_List_v3()
Set wsSource = Worksheets("Registration")
Set wsTarget = Worksheets("Presenter List")
Set wsPart = Worksheets("Participant List")
Dim lastRow As Long
Application.ScreenUpdating = False
Range("A12:E111").ClearContents
wsSource.Activate
Application.ScreenUpdating = False
Dim r As Range
Set r = wsSource.Cells(2, 6)
r.Select
wsSource.Sort.SortFields.Clear
wsSource.Sort.SortFields.Add Key:=r, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wsSource.Sort
.SetRange Range("A2", Range("A2").End(xlDown).End(xlToRight))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
wsSource.Range("A2") = 1
wsSource.Range("A2").Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Stop:=Cells(Rows.Count, "A").End(xlUp).Row - 1, Trend:=False
For i = 1 To Cells(Rows.Count, "C").End(xlUp).Row
If InStr(1, wsSource.Cells(i, 3).Value, "Complete") > 0 Then
With wsTarget
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Cells(i, 1).Copy
.Cells(lastRow + 1, "A").PasteSpecial
Cells(i, 3).Copy
.Cells(lastRow + 1, "B").PasteSpecial
Cells(i, 8).Copy
.Cells(lastRow + 1, "C").PasteSpecial
Cells(i, 6).Copy
.Cells(lastRow + 1, "D").PasteSpecial
Cells(i, 2).Copy
.Cells(lastRow + 1, "E").PasteSpecial
End With
ElseIf InStr(1, wsSource.Cells(i, 3).Value, "Tentative") > 0 Then
With wsTarget
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Cells(i, 1).Copy
.Cells(lastRow + 1, "A").PasteSpecial
Cells(i, 3).Copy
.Cells(lastRow + 1, "B").PasteSpecial
Cells(i, 8).Copy
.Cells(lastRow + 1, "C").PasteSpecial
Cells(i, 6).Copy
.Cells(lastRow + 1, "D").PasteSpecial
Cells(i, 2).Copy
.Cells(lastRow + 1, "E").PasteSpecial
End With
End If
Next i
wsTarget.Activate
Application.Goto Reference:="R12C1"
Selection.End(xlDown).Select
Dim maxRowIndex As Integer
'-4 to account for the header row. Remove or adjust at will
maxRowIndex = ActiveCell.Row - 11
Range("A12").Select
Dim rowCounter As Integer
rowCounter = 1
For rowCounter = 1 To maxRowIndex
'populate number in sequence
ActiveCell = rowCounter
'go to next row
ActiveCell.Offset(1).Select
Next
Dim lRow As Integer
With wsPart
lRow = wsTarget.Range("A5").CurrentRegion.Rows.Count
.Range("A5:F9").Copy wsTarget.Range("A5")
End With
Rows(8).RowHeight = 10.5
Dim rngBlnk As Range
On Error Resume Next
Set rngBlnk = Range("A5:A7").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rngBlnk Is Nothing Then
rngBlnk.EntireRow.Hidden = True
End If
Application.ScreenUpdating = True
End Sub
Display More
Is there a reason why this may be occurring?
Thanks