I refactored the code a bit. I discovered that the file is corrupt.
see:
https://stackoverflow.com/questions/...nd-it#29943113
https://superuser.com/questions/8743...rupt-workbooks
Option Explicit
Private Sub test() 'CommandButton1_Click()
Dim lastrowsheet1_colA As Long
Dim lastrowsheet1_colC As Long
Dim lastrowsheet1_colD As Long
Dim lastrowsheet1_final As Long
Dim rgFoundstart As Range
Dim datestart 'As Date
Dim dateend As Long
Dim ColumnLettersFromRangeend As String
Dim columnletterstart As String
Dim columnletterEnd As String
Dim workingrow As Long
Dim i As Long
Dim therange As String
Dim namerange As String
Dim chk As Long
Dim j As Long
'CLEAR CONTENTS OF PRINT SCHEDULE SHEET''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'lastrow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
With Sheets("Print Schedule")
.Range("a4:t150").ClearContents
.Cells(3, 1) = "Last Updated: " & Date
.Cells(4, 1) = "First"
.Cells(4, 2) = "Last"
If Cells(1, 4) > Cells(2, 4) Then MsgBox ("'End Date' must be greater than 'Start Date' Please change")
End With
'FIND LAST ROW IN SHEET1 FOR COLUMN A, C and D''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Worksheets("Vacation Schedule")
lastrowsheet1_colA = .Cells(.Rows.Count, "a").End(xlUp).Row
lastrowsheet1_colC = .Cells(.Rows.Count, "c").End(xlUp).Row
lastrowsheet1_colD = .Cells(.Rows.Count, "d").End(xlUp).Row
lastrowsheet1_final = WorksheetFunction.Max(lastrowsheet1_colA, lastrowsheet1_colC, lastrowsheet1_colD) ' find max number of set of last row variables
'START DATE ENTERED - EXTRACT ADDRESS AND COLUMN ADDRESS ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
datestart = Worksheets("Print Schedule").Cells(1, 2)
Set rgFoundstart = .Range("g3:nn3").Find(datestart, LookAt:=xlPart, LookIn:=xlFormulas)
If Not rgFoundstart Is Nothing Then
Cells(1, 15) = "ok"
Else
Cells(1, 15) = "not ok"
End If
End With
'END DATE ENTERED - EXTRACT ADDRESS AND COLUMN ADDRESS ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dateend = Worksheets("Print Schedule").Cells(2, 2)
Dim rgFoundend As Range
Set rgFoundend = Worksheets("Vacation Schedule").Range("g3:nn3").Find(dateend) 'find cell with start date entered by user
ColumnLettersFromRangeend = Split(rgFoundend.Address, "$")(1) ' obtains column letter for start date
Cells(1, 7) = ColumnLettersFromRangeend
Cells(1, 10) = rgFoundend
'FIND IF ROW BETWEEN START DATE COLUMN AND END DATE COLUMN IS NOT EMPTY (COUNTA) AND PASS TO PRINT SCHEDULE SHEET
columnletterstart = "g"
columnletterEnd = "s"
workingrow = 3
For i = 3 To lastrowsheet1_final
therange = columnletterstart & i & ":" & columnletterEnd & i 'string for range
namerange = "C" & i & ":" & "D" & i
With Worksheets("Vacation Schedule")
If Application.WorksheetFunction.CountA(.Range(therange)) > 0 Then 'test to see if range is not empty
.Range(therange).Copy Destination:=Worksheets("Print Schedule").Cells(workingrow + 2, 3) 'copy 'V' to colC
.Range(namerange).Copy Destination:=Worksheets("Print Schedule").Cells(workingrow + 2, 1) 'copy first and last name to ColA
chk = chk + 1
Cells(4, 5) = chk
Else
workingrow = workingrow - 1
j = j + 1
Cells(2, 5) = "empty" & j
End If
Cells(3, 5) = "i =" & i
workingrow = workingrow + 1
End With
Next
End Sub
Reply With Quote
Originally Posted by SamT
