Solved: Take values from one sheet and dump into another

[sujittalukde]

i have attached a sample file . I want a macro that will loop through attendance sheet for each name of employee and will pick dates for which leaves are assigned to him/her and dump those values to the sheet(Leave) in the predefined location.
THe values to be dumped in the yellow coloured cells for each name in the leave sheet.
I have given some dates manually but this needs to be done by the macro.
In case more info required, do let me know.

[Bob Phillips]

[vba]

Public Sub LeaveSummary()
Dim Attendance As Worksheet
Dim Leave As Worksheet
Dim LastRow As Long
Dim LastCol As Long
Dim NextRow As Long
Dim aryCL As Variant
Dim aryPL As Variant
Dim CLIndex As Long
Dim PLIndex As Long
Dim i As Long, j As Long

Set Attendance = Worksheets("Attendance")
Set Leave = Worksheets("Leave")

NextRow = 3
With Attendance

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 4 To LastRow

LastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
ReDim aryCL(1 To LastCol - 4)
ReDim aryPL(1 To LastCol - 4)
CLIndex = 0
PLIndex = 0
For j = 5 To LastCol

If LCase(.Cells(i, j).Value) = "cl" Then

CLIndex = CLIndex + 1
aryCL(CLIndex) = .Cells(1, j).Value
End If

If LCase(.Cells(i, j).Value) = "pl" Then

PLIndex = PLIndex + 1
aryPL(PLIndex) = .Cells(1, j).Value
End If
Next j

If CLIndex > 0 Then

ReDim Preserve aryCL(1 To CLIndex)
Leave.Cells(i - 1, "I").Value = Join(aryCL, ",")
End If

If PLIndex > 0 Then

ReDim Preserve aryPL(1 To PLIndex)
Leave.Cells(i - 1, "O").Value = Join(aryPL, ",")
End If
Next i
End With
End Sub
[/vba]

[sujittalukde]

Thanks , its working well.

[sujittalukde]

Hello xld,
My apology for reopening the solved thread.
I have one more request.
In case leaves are more duays say 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 ie continuous or brken days leave say 3,4,5,6,7,8,9,10,11,12,13,14,15 ,23,28 then can "To" be added for continuous ranges. Like this:
1 to 15
3 to 15,23,28
This will reduce the awkward row size and also reduce papers for printing.
If this is possible can you post a sample code?

[Bob Phillips]

[vba]

Public Sub LeaveSummary()
Dim Attendance As Worksheet
Dim Leave As Worksheet
Dim LastRow As Long
Dim LastCol As Long
Dim NextRow As Long
Dim aryCL As Variant
Dim aryPL As Variant
Dim CLIndex As Long
Dim PLIndex As Long
Dim i As Long, j As Long

Set Attendance = Worksheets("Attendance")
Set Leave = Worksheets("Leave")

NextRow = 3
With Attendance

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 4 To LastRow

LastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
ReDim aryCL(1 To LastCol - 4)
ReDim aryPL(1 To LastCol - 4)
CLIndex = 0
PLIndex = 0
For j = 5 To LastCol

If LCase(.Cells(i, j).Value) = "cl" Then

If LCase(.Cells(i, j - 1).Value) = "cl" Then

If aryCL(CLIndex) Like "*to*" Then

aryCL(CLIndex) = Left$(aryCL(CLIndex), InStr(aryCL(CLIndex), "to") + 2) & .Cells(1, j).Value
Else

aryCL(CLIndex) = aryCL(CLIndex) & " to " & .Cells(1, j).Value
End If
Else

CLIndex = CLIndex + 1
aryCL(CLIndex) = .Cells(1, j).Value
End If
End If

If LCase(.Cells(i, j).Value) = "pl" Then

If LCase(.Cells(i, j - 1).Value) = "pl" Then

If aryPL(PLIndex) Like "*to*" Then

aryPL(PLIndex) = Left$(aryPL(PLIndex), InStr(aryPL(PLIndex), "to") + 2) & .Cells(1, j).Value
Else

aryPL(PLIndex) = aryPL(PLIndex) & " to " & .Cells(1, j).Value
End If
Else

PLIndex = PLIndex + 1
aryPL(PLIndex) = .Cells(1, j).Value
End If
End If
Next j

If CLIndex > 0 Then

ReDim Preserve aryCL(1 To CLIndex)
Leave.Cells(i - 1, "I").Value = Join(aryCL, ",")
End If

If PLIndex > 0 Then

ReDim Preserve aryPL(1 To PLIndex)
Leave.Cells(i - 1, "O").Value = Join(aryPL, ",")
End If
Next i
End With
End Sub
[/vba]