You want us to verify the code and make amendments ? or. .. what ?
the code works how it is and how and when to activate it ?
gowflow
You say records in sheet2 13 to 18 3 records
2058, Flemming Olsen, Ferie, 17-11-2014, 20-11-2014
2061. Peter Dahl, Ferie, 03-11-2014, 03-11-2014
2061. Peter Dahl, Ferie, 17-11-2014, 17-11-2014
Option Explicit
Dim wsIn As Worksheet, wsOut As Worksheet
Dim rwIn As Long, rwInMax As Long, rwOut As Long, col As Integer
Dim DataRange As Range
Dim Days As Single
Sub ArrangeEmployees()
Set wsIn = Sheets("Sheet2")
Set wsOut = Sheets("Ark2")
Application.ScreenUpdating = False
wsOut.Cells.ClearContents
wsOut.Range("A1:H1") = Array("Løn nr", "Medarbejder", "CPR", "Konto", "Start", "Slut", "Dage", "Arbejdsdage")
rwInMax = wsIn.Range("A1").CurrentRegion.Rows.Count
Set DataRange = wsIn.Range(Cells(1, 1), Cells(rwInMax, wsIn.Range("A1").CurrentRegion.Columns.Count))
DataRange.Sort Key1:="Løn nr", Order1:=xlAscending, Key2:="Dato", Order2:=xlAscending, Header:=xlYes
rwIn = 1
rwOut = 1
NewLine
For rwIn = 2 To rwInMax
If wsIn.Range("B" & (rwIn + 1)) = wsIn.Range("B" & rwIn) _
And wsIn.Range("E" & (rwIn + 1)) = wsIn.Range("E" & rwIn) _
And wsIn.Range("A" & (rwIn + 1)) = wsIn.Range("A" & rwIn) + 1 Then
Days = Days + wsIn.Range("F" & (rwIn + 1))
Else
wsOut.Range("F" & rwOut) = wsIn.Range("A" & rwIn)
wsOut.Range("G" & rwOut) = Days
wsOut.Range("H" & rwOut) = Application.WorksheetFunction.NetworkDays(wsOut.Range("E" & rwOut), wsOut.Range("F" & rwOut))
If rwIn < rwInMax Then
NewLine
End If
End If
Next rwIn
wsOut.Select
wsOut.Columns.AutoFit
Application.ScreenUpdating = True
wsOut.Range("A1").Select
End Sub
Sub NewLine()
rwOut = rwOut + 1
For col = 2 To 5
wsOut.Cells(rwOut, col - 1) = wsIn.Cells(rwIn + 1, col)
Next col
wsOut.Range("E" & rwOut) = wsIn.Range("A" & (rwIn + 1))
Days = wsIn.Range("F" & (rwIn + 1))
End Sub
Experts-Exchange-Repeats-A.xlsm
Option Explicit
Dim wsIn As Worksheet, wsOut As Worksheet
Dim rwIn As Long, rwInMax As Long, rwOut As Long, col As Integer
Dim DataRange As Range
Dim Days As Single
Sub ArrangeEmployees()
Set wsIn = Sheets("Sheet2")
Set wsOut = Sheets("Ark2")
Application.ScreenUpdating = False
'Clear the contents of the destination sheet
wsOut.Cells.ClearContents
'Set the headers of destination sheet
wsOut.Range("A1:H1") = Array("Løn nr", "Medarbejder", "CPR", "Konto", "Start", "Slut", "Dage", "Arbejdsdage")
'Count the rows in the source sheet
rwInMax = wsIn.Range("A1").CurrentRegion.Rows.Count
'Define the size of the input DataRange and sets it as range
Set DataRange = wsIn.Range(Cells(1, 1), Cells(rwInMax, wsIn.Range("A1").CurrentRegion.Columns.Count))
'Sort the DataRange based on first Løn nr. and afterwards Dato in Ascending Order
DataRange.Sort Key1:="Løn nr", Order1:=xlAscending, Key2:="Dato", Order2:=xlAscending, Header:=xlYes
rwIn = 1
rwOut = 1
'run the subprocedure NewLine to put in the information from the destination sheet
NewLine
For rwIn = 2 To rwInMax 'repeat until you reach the bottom of the sourcesheet or actually the datarange set
'If the value of the "lønnr" and the "Konto" in the cell below equals the value of the "lønnr" and "Konto" on the
'row we check and the day below is one larger, than the row we check then we increase the Days counter
If wsIn.Range("B" & (rwIn + 1)) = wsIn.Range("B" & rwIn) _
And wsIn.Range("E" & (rwIn + 1)) = wsIn.Range("E" & rwIn) _
And wsIn.Range("A" & (rwIn + 1)) = wsIn.Range("A" & rwIn) + 1 Then
Days = Days + wsIn.Range("F" & (rwIn + 1))
Else
' if one of the three statements above is not true then "Slut" column will equal the date from colomn A in sourcesheet
wsOut.Range("F" & rwOut) = wsIn.Range("A" & rwIn)
' in column G you insert the number of Days
wsOut.Range("G" & rwOut) = Days
'and you insert the formula for netWorkDays in column H based on the days in Column E and F
wsOut.Range("H" & rwOut) = Application.WorksheetFunction.NetworkDays(wsOut.Range("E" & rwOut), wsOut.Range("F" & rwOut))
' If We are not at the bottom of our sourcesheet, we should go to the next record, and run the subprocedure NewLine
If rwIn < rwInMax Then
NewLine
End If
End If
Next rwIn
'Select the destination sheet and autofit all columns - Unfreeze ScreenUpdating and select cell A1 in destination sheet
wsOut.Select
wsOut.Columns.AutoFit
Application.ScreenUpdating = True
wsOut.Range("A1").Select
End Sub
Sub NewLine()
'add 1 to rwOut counter
rwOut = rwOut + 1
For col = 2 To 5
'inserts values from column B to E from source sheet in column A to D in destination sheet
wsOut.Cells(rwOut, col - 1) = wsIn.Cells(rwIn + 1, col)
Next col
'In column E you insert the startdate, that you find in column A
wsOut.Range("E" & rwOut) = wsIn.Range("A" & (rwIn + 1))
'???????
Days = wsIn.Range("F" & (rwIn + 1))
End Sub
Option Explicit
Dim wsIn As Worksheet, wsOut As Worksheet
Dim rwIn As Long, rwInMax As Long, rwOut As Long, col As Integer
Dim DataRange As Range
Dim Days As Single
Sub ArrangeEmployees()
Set wsIn = Sheets("Sheet2")
Set wsOut = Sheets("Ark2")
Application.ScreenUpdating = False
'Clear the contents of the destination sheet
wsOut.Cells.ClearContents
'Set the headers of destination sheet
wsOut.Range("A1:H1") = Array("Løn nr", "Medarbejder", "CPR", "Konto", "Start", "Slut", "Dage", "Arbejdsdage")
'Count the rows in the source sheet
rwInMax = wsIn.Range("A1").CurrentRegion.Rows.Count
'Define the size of the input DataRange and sets it as range
Set DataRange = wsIn.Range(Cells(1, 1), Cells(rwInMax, wsIn.Range("A1").CurrentRegion.Columns.Count))
'Sort the DataRange based on first Løn nr. and afterwards Dato in Ascending Order
DataRange.Sort Key1:="Løn nr", Order1:=xlAscending, Key2:="Dato", Order2:=xlAscending, Header:=xlYes
rwIn = 1
rwOut = 1
'run the subprocedure NewLine to put in the information from the destination sheet
NewLine
For rwIn = 2 To rwInMax 'repeat until you reach the bottom of the sourcesheet or actually the datarange set
'If the value of the "lønnr" and the "Konto" in the cell below equals the value of the "lønnr" and "Konto" on the
'row we check and the day below is one larger, than the row we check then we increase the Days counter with the value
'in column F Row (rwIn + 1), and continue counting Days
'We do not read further information into the destination source until above statement is met (We just increase the
'Days counter), and then we increase the counter. When above statement is met we inserts the date from Column A in the
'Source sheet in column F of the destination sheet, and column G equals the variable Days.
If wsIn.Range("B" & (rwIn + 1)) = wsIn.Range("B" & rwIn) _
And wsIn.Range("E" & (rwIn + 1)) = wsIn.Range("E" & rwIn) _
And wsIn.Range("A" & (rwIn + 1)) = wsIn.Range("A" & rwIn) + 1 Then
Days = Days + wsIn.Range("F" & (rwIn + 1))
Else
' if one of the three statements above is not true then "Slut" column will equal the date from colomn A in sourcesheet
wsOut.Range("F" & rwOut) = wsIn.Range("A" & rwIn)
' in column G you insert the number of Days
wsOut.Range("G" & rwOut) = Days
'and you insert the value of the formula for netWorkDays in column H based on the days in Column E and F
'This code still needs to be updated by a list of Public Holidays
wsOut.Range("H" & rwOut) = Application.WorksheetFunction.NetworkDays(wsOut.Range("E" & rwOut), wsOut.Range("F" & rwOut))
' If We are not at the bottom of our sourcesheet, we should go to the next record, and run the subprocedure NewLine
If rwIn < rwInMax Then
NewLine
End If
End If
Next rwIn
'Select the destination sheet and autofit all columns - Unfreeze ScreenUpdating and select cell A1 in destination sheet
wsOut.Select
wsOut.Columns.AutoFit
Application.ScreenUpdating = True
wsOut.Range("A1").Select
End Sub
Sub NewLine()
'add 1 to rwOut counter
rwOut = rwOut + 1
For col = 2 To 5
'inserts values from column B to E from source sheet in column A to D in destination sheet
wsOut.Cells(rwOut, col - 1) = wsIn.Cells(rwIn + 1, col)
Next col
'In column E you insert the startdate, that you find in column A
wsOut.Range("E" & rwOut) = wsIn.Range("A" & (rwIn + 1))
' resets the Days counter so it just sums the value in the cell to insert in the destination sheet
Days = wsIn.Range("F" & (rwIn + 1))
End Sub
Title | # Comments | Views | Activity |
---|---|---|---|
Excel and Formulas | 8 | 31 | |
TT Text To Column Based On Criteria | 3 | 18 | |
Excel: Comparing the Values in One Column with the Values in Another | 2 | 29 | |
How to check with VBA if an excel formula has multiple terms in it? | 2 | 26 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
22 Experts available now in Live!