View Full Version : Solved: Take values from one sheet and dump into another
sujittalukde
11-20-2008, 10:22 PM
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
11-21-2008, 03:53 AM
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
sujittalukde
11-21-2008, 10:35 PM
Thanks , its working well.
sujittalukde
11-26-2008, 01:24 AM
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
11-26-2008, 01:59 AM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.