add feature in code

P

poem

New member
Joined
Jul 1, 2015
Messages
16
Reaction score
0
Points
0
couldyou arrange me feature like
startdate for each cell = date serial( 2015,06,01)
enddate for each cell =date serial (2015,06,30)
noteif frist date not mentiond ( 2015,06,01) insert blank row
andinsert blank row till end date (2015,06,30)
addin this code
1. Subblah()
2. ForEach are In ActiveSheet.UsedRange.Offset(1).SpecialCells(xlCellTypeConstants,23).Areas
3. diff =CLng(Application.WorksheetFunction.EoMonth(are.Rows(are.Rows.Count).Cells(2).Value,0) - are.Rows(are.Rows.Count).Cells(2).Value)
4. If diff > 0 Then
5. are.Rows(are.Rows.Count).Offset(1).Resize(diff).InsertShift:=xlDown
6. are.Rows(are.Rows.Count).Resize(,2).AutoFill Destination:=are.Rows(are.Rows.Count).Resize(diff + 1, 2)
7. End If
8. For rw = are.Rows.Count To 1 Step -1
9. Select Case rw
10. Case 1
11. diff = Day(are.Rows(rw).Cells(2).Value)
12. If diff > 1 Then
13. are.Rows(rw).Resize(diff - 1).InsertShift:=xlDown
14. are.Rows(rw).Resize(, 2).AutoFillDestination:=are.Rows(rw).Offset(1 - diff).Resize(diff, 2), Type:=xlFillDefault
15. End If
16. Case Else
17. diff = are.Rows(rw).Cells(2).Value -are.Rows(rw - 1).Cells(2).Value
18. If diff > 1 Then
19. are.Rows(rw).Resize(diff - 1).InsertShift:=xlDown
20. are.Rows(rw - 1).Resize(, 2).AutoFillDestination:=are.Rows(rw - 1).Resize(diff, 2), Type:=xlFillDefault
21. End If
22. End Select
23. Next rw
24. Nextare
​
End Sub
 

Attachments

  • sheet 2 .xlsx
    144.8 KB · Views: 7
thank you too much for solving i appericate you
 
You must log in or register to reply here.
Back
Top