Solved VBA in excel HELP

June 27, 2013 at 07:15:36
Specs: Windows 7
I used the following script to insert missing dates of the month showing inactivity. Diagram A shows the dates of the month when someone works. Applying the script shown below, the dates in between not worked are included but show no work was logged – but just the date.
However, what I need to show is from the 1st day of the month to the last for each employee – as currently it will only fill in the in between dates from the 1st date in the month they actually worked:
E.g. If Daisy’s 1st working day in the month in the 8th and the last working day is the 29th – all dates from the 8th to the 29th are shown – and whether she worked or not. What I need is from the 1st to the 31st to show – for each employee. (Please see Diagram’s A and B).

Public Sub ProcessData()
Const TEST_COLUMN As String = "F"    '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim tmp As Long

    With ActiveSheet
        
        LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
        For i = LastRow To 2 Step -1
        
            If .Cells(i, "F").Value <> .Cells(i + 1, "F").Value And _
                .Cells(i, "F").Value < .Cells(i + 1, "F").Value - 1 Then
                
                tmp = .Cells(i + 1, "F").Value
                .Rows(i + 1).Resize(tmp - .Cells(i, "F").Value - 1).Insert
                .Cells(i, "F").AutoFill .Cells(i, "F").Resize(tmp - .Cells(i, "F").Value)
                .Cells(i + 1, "L").Resize(tmp - .Cells(i, "F").Value - 1, 4).Value = 0
            End If
        Next i
        
    End With
    
End Sub


edited by moderator: Added pre tags -Razor2.3


See More: VBA in excel HELP

Report •


✔ Best Answer
June 30, 2013 at 10:13:00
I think I know what the problem is. When I looked at your Screen Capture I thought you had multiple sheets in your workbook. If you have a only one, the code will fail when it tries to access Sheet(2).

"Subscript out of range" means that the object that VBA is trying to access doesn't exist.

The purpose of that section is to allow the code to delete the old AllDates sheet and create a new one whenever you make a change to Sheet1 and re-run the code. However, as written, there has to be more than one sheet in the workbook.

This version will check for multiple sheets before trying to access Sheet 2. Let me know how it works for you. As I said before, since I am running this against a test workbook that I created, there still may be differences in your workbook that causes problems. We'll work through them as they arise.


Sub FillInDates()
'Delete AllDates sheet if it exists
  If Sheets.Count > 1 Then
    Application.DisplayAlerts = False
      If Sheets(2).Name = "AllDates" Then Sheets(2).Delete
    Application.DisplayAlerts = True
  End If
'Add a sheet in the second position, Fill in headers
  Sheets.Add after:=Sheets(1)
   ActiveSheet.Name = "AllDates"
    Sheets(1).Rows(1).EntireRow.Copy _
     Destination:=Sheets(2).Range("A1")
     
'Get Month Number from Date in Sheet1!F2
   curDate = Sheets(1).Range("F2")
   curMonth = Month(curDate)
'Determine First and Last Day Of Month
   firstDay = DateSerial(Year(curDate), Month(curDate), 1)
   lastDay = Day(DateSerial(Year(curDate), Month(curDate) + 1, 0))
   
'Count unique names in Sheet1 Column B (stolen code)
  With CreateObject("Scripting.Dictionary") 'Create dictionary
    .comparemode = vbTextCompare
    For i = 2 To Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
        '.exists checks if dictionary contains item
        'If it doesn't then it adds
        If Not .exists(Sheets(1).Range("B" & i).Value) Then _
          .Add Sheets(1).Range("B" & i).Value, Range("B" & i).Value
    Next i
    'Get count of elements in dictionary
    numNames = .Count
  End With
  
'Initialize row number for first Date on Sheet2
   startRw = 2
'Create groups of dates for each name
  For numGrps = 1 To numNames
    Sheets(2).Range("F" & startRw) = firstDay
    Sheets(2).Range("F" & startRw).AutoFill _
      Destination:=Sheets(2).Range("F" & startRw & ":F" & startRw + lastDay - 1)
   startRw = startRw + lastDay
  Next
  Sheets("AllDates").Range("F:F").Columns.AutoFit
'Find each date from Sheet1 Column F in Sheet("AllDates") Column F
'Set each Search Range to be each group of dates so that data is
'copied to the correct row
   dateGroup = 1
    For nxtRw = 2 To Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
      With Sheets(2).Range("F" & dateGroup & ":F" & dateGroup + lastDay)
       Set w = .Find(Sheets(1).Range("F" & nxtRw))
         Sheets(1).Range("F" & nxtRw).EntireRow.Copy _
           Destination:=Sheets(2).Range("A" & w.Row)
      End With
'Increment dateGroup when Column B name changes
       If Sheets(1).Range("B" & nxtRw) <> Sheets(1).Range("B" & nxtRw + 1) Then
          dateGroup = dateGroup + lastDay
       End If
    Next
End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.



#1
June 27, 2013 at 08:59:58
re: "(Please see Diagram’s A and B)."

What diagrams?

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#2
June 27, 2013 at 14:34:55
Diagrams for pics
Watch this, its the diagrams

Report •

#3
June 28, 2013 at 04:31:22
Are the values in the cells text data or are there formulas involved?

If it's all just data then writing code to create a sheet of all dates and then copy the date specific data over might be easier than trying to fill in missing dates.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

Related Solutions

#4
June 28, 2013 at 15:44:43
This might work for you, although it works a bit differently than your existing code. Instead of adding the missing dates to your existing sheet, it creates a new sheet with all the dates and then copies over all the data.

1 - The code creates a new sheet named AllDates
2 - It then fills AllDates Column F with all dates of the month in Sheet1!F2, with a month's worth of dates for each person named in Sheet1 Column B. 3 unique names, 3 sets of dates, etc.
3 - Once AllDates is filled with dates, it copies the data from Sheet1 into AllDates, placing each person's data in the row that matches the date from Sheet1.

Let me know what you think.

Sub FillInDates()
'Delete AllDates sheet if it exists
  Application.DisplayAlerts = False
   If Sheets(2).Name = "AllDates" Then Sheets(2).Delete
  Application.DisplayAlerts = True
'Add a sheet in the second position, Fill in headers
  Sheets.Add after:=Sheets(1)
   ActiveSheet.Name = "AllDates"
    Sheets(1).Rows(1).EntireRow.Copy _
     Destination:=Sheets(2).Range("A1")
     
'Get Month Number from Date in Sheet1!F2
   curDate = Sheets(1).Range("F2")
   curMonth = Month(curDate)
'Determine First and Last Day Of Month
   firstDay = DateSerial(Year(curDate), Month(curDate), 1)
   lastDay = Day(DateSerial(Year(curDate), Month(curDate) + 1, 0))
   
'Count unique names in Sheet1 Column B (stolen code)
  With CreateObject("Scripting.Dictionary") 'Create dictionary
    .comparemode = vbTextCompare
    For i = 2 To Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
        '.exists checks if dictionary contains item
        'If it doesn't then it adds
        If Not .exists(Sheets(1).Range("B" & i).Value) Then _
            .Add Sheets(1).Range("B" & i).Value, Range("B" & i).Value
    Next i
    'Get count of elements in dictionary
    numNames = .Count
  End With
  
'Initialize row number for first Date on Sheet2
   startRw = 2
'Create groups of dates for each name
  For numGrps = 1 To numNames
    Sheets(2).Range("F" & startRw) = firstDay
    Sheets(2).Range("F" & startRw).AutoFill _
      Destination:=Sheets(2).Range("F" & startRw & ":F" & startRw + lastDay - 1)
   startRw = startRw + lastDay
  Next
  Sheets("AllDates").Range("F:F").Columns.AutoFit
'Find each date from Sheet1 Column F in Sheet("AllDates") Column F
'Set each Search Range to be each group of dates so that data is
'copied to the correct row
   dateGroup = 1
    For nxtRw = 2 To Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
      With Sheets(2).Range("F" & dateGroup & ":F" & dateGroup + lastDay)
       Set w = .Find(Sheets(1).Range("F" & nxtRw))
         Sheets(1).Range("F" & nxtRw).EntireRow.Copy _
           Destination:=Sheets(2).Range("A" & w.Row)
      End With
'Increment dateGroup when Column B name changes
       If Sheets(1).Range("B" & nxtRw) <> Sheets(1).Range("B" & nxtRw + 1) Then
          dateGroup = dateGroup + lastDay
       End If
    Next
End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#5
June 30, 2013 at 02:57:01
When i go to run it i get Run-time error 9: Subscript out of range ? any ideas?

Report •

#6
June 30, 2013 at 05:56:03
Keep in mind that I don't have a copy of your workbook to test the code on. Based on the example of data that you posted I created a work with data in the same columns. The data was entered on Sheet1. I then wrote the code to work with my setup. It's very possible that the error is due to the fact your workbook is set up differently than mine.

If the error appears with a dialog box that has a Debug button then please click the button. The line that is causing the error should be highlighted. If I know what line is highlighted, it will be easier for me to determine the problem.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#7
June 30, 2013 at 07:23:45
This is what is highlighted

If Sheets(2).Name = "AllDates" Then


Report •

#8
June 30, 2013 at 10:13:00
✔ Best Answer
I think I know what the problem is. When I looked at your Screen Capture I thought you had multiple sheets in your workbook. If you have a only one, the code will fail when it tries to access Sheet(2).

"Subscript out of range" means that the object that VBA is trying to access doesn't exist.

The purpose of that section is to allow the code to delete the old AllDates sheet and create a new one whenever you make a change to Sheet1 and re-run the code. However, as written, there has to be more than one sheet in the workbook.

This version will check for multiple sheets before trying to access Sheet 2. Let me know how it works for you. As I said before, since I am running this against a test workbook that I created, there still may be differences in your workbook that causes problems. We'll work through them as they arise.


Sub FillInDates()
'Delete AllDates sheet if it exists
  If Sheets.Count > 1 Then
    Application.DisplayAlerts = False
      If Sheets(2).Name = "AllDates" Then Sheets(2).Delete
    Application.DisplayAlerts = True
  End If
'Add a sheet in the second position, Fill in headers
  Sheets.Add after:=Sheets(1)
   ActiveSheet.Name = "AllDates"
    Sheets(1).Rows(1).EntireRow.Copy _
     Destination:=Sheets(2).Range("A1")
     
'Get Month Number from Date in Sheet1!F2
   curDate = Sheets(1).Range("F2")
   curMonth = Month(curDate)
'Determine First and Last Day Of Month
   firstDay = DateSerial(Year(curDate), Month(curDate), 1)
   lastDay = Day(DateSerial(Year(curDate), Month(curDate) + 1, 0))
   
'Count unique names in Sheet1 Column B (stolen code)
  With CreateObject("Scripting.Dictionary") 'Create dictionary
    .comparemode = vbTextCompare
    For i = 2 To Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
        '.exists checks if dictionary contains item
        'If it doesn't then it adds
        If Not .exists(Sheets(1).Range("B" & i).Value) Then _
          .Add Sheets(1).Range("B" & i).Value, Range("B" & i).Value
    Next i
    'Get count of elements in dictionary
    numNames = .Count
  End With
  
'Initialize row number for first Date on Sheet2
   startRw = 2
'Create groups of dates for each name
  For numGrps = 1 To numNames
    Sheets(2).Range("F" & startRw) = firstDay
    Sheets(2).Range("F" & startRw).AutoFill _
      Destination:=Sheets(2).Range("F" & startRw & ":F" & startRw + lastDay - 1)
   startRw = startRw + lastDay
  Next
  Sheets("AllDates").Range("F:F").Columns.AutoFit
'Find each date from Sheet1 Column F in Sheet("AllDates") Column F
'Set each Search Range to be each group of dates so that data is
'copied to the correct row
   dateGroup = 1
    For nxtRw = 2 To Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
      With Sheets(2).Range("F" & dateGroup & ":F" & dateGroup + lastDay)
       Set w = .Find(Sheets(1).Range("F" & nxtRw))
         Sheets(1).Range("F" & nxtRw).EntireRow.Copy _
           Destination:=Sheets(2).Range("A" & w.Row)
      End With
'Increment dateGroup when Column B name changes
       If Sheets(1).Range("B" & nxtRw) <> Sheets(1).Range("B" & nxtRw + 1) Then
          dateGroup = dateGroup + lastDay
       End If
    Next
End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#9
June 30, 2013 at 15:42:04
Thanks very much this has worked fantastically. The only thing i now need to show is each employees name against the relevents dates I.E 1st to the 31st for daisy with her name showing beside all these dates no mater if she worked the or not THANKS SOO MUCH!

Report •

#10
June 30, 2013 at 17:00:13
Your example data did not show names next to every date.

Adding additional requirements after a solution to the original question has been given can mean a lot of wasted time for the person who offered the solution. Very often "bolting on" additional code to address the new requirement results in efficient code. Since we don't want suggest inefficient code, we often have to go back and rewrite sections of the code to incorporate the new requirements.

I will work on changing the code to fill in the names for all of the dates, but in the future we would appreciate it if you include all of your requirements in the original question.

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#11
July 1, 2013 at 09:03:18
Try this version:


Sub FillInDates()
'Delete AllDates sheet if it exists
  If Sheets.Count > 1 Then
    Application.DisplayAlerts = False
      If Sheets(2).Name = "AllDates" Then Sheets(2).Delete
    Application.DisplayAlerts = True
  End If
'Add a sheet in the second position, Fill in headers
  Sheets.Add after:=Sheets(1)
   ActiveSheet.Name = "AllDates"
    Sheets(1).Rows(1).EntireRow.Copy _
     Destination:=Sheets(2).Range("A1")
     
'Get Month Number from Date in Sheet1!F2
   curDate = Sheets(1).Range("F2")
   curMonth = Month(curDate)
'Determine First and Last Day Of Month
   firstDay = DateSerial(Year(curDate), Month(curDate), 1)
   lastDay = Day(DateSerial(Year(curDate), Month(curDate) + 1, 0))
   
'Count unique names in Sheet1 Column B
  Set empNames = CreateObject("Scripting.Dictionary")  'Create dictionary
   With empNames
    .comparemode = vbTextCompare
      For i = 2 To Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
        '.exists checks if dictionary contains item
        'If it doesn't then it adds
        If Not .exists(Sheets(1).Range("B" & i).Value) Then _
          .Add Sheets(1).Range("B" & i).Value, Sheets(1).Range("B" & i).Value
      Next i
    'Get count of elements in dictionary
    numNames = .Count
    empNamesItems = empNames.Items()
  End With
  
'Initialize row number for first Date on Sheet2
   startRw = 2

'Create groups of dates for each name. Dates In Col F, Names in Col B
  For numGrps = 1 To numNames
    Sheets(2).Range("F" & startRw) = firstDay
    Sheets(2).Range("F" & startRw).AutoFill _
      Destination:=Sheets(2).Range("F" & startRw & ":F" & startRw + lastDay - 1)
    Sheets(2).Range("B" & startRw & ":B" & startRw + lastDay - 1) _
                = empNamesItems(numGrps - 1)     startRw = startRw + lastDay
  Next
  Sheets("AllDates").Range("F:F").Columns.AutoFit

'Find each date from Sheet1 Column F in Sheet("AllDates") Column F
'Set each Search Range to be each group of dates so that data is
'copied to the correct row
   dateGroup = 1
    For nxtRw = 2 To Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
      With Sheets(2).Range("F" & dateGroup & ":F" & dateGroup + lastDay)
       Set w = .Find(Sheets(1).Range("F" & nxtRw))
         Sheets(1).Range("F" & nxtRw).EntireRow.Copy _
           Destination:=Sheets(2).Range("A" & w.Row)
      End With

'Increment dateGroup when Column B name changes
       If Sheets(1).Range("B" & nxtRw) <> Sheets(1).Range("B" & nxtRw + 1) Then
          dateGroup = dateGroup + lastDay
       End If
    Next
End Sub

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#12
July 1, 2013 at 09:34:07
Sheets(2).Range("B" & startRw & ":B" & startRw + lastDay - 1) _
= empNamesItems(numGrps - 1) startRw = startRw + lastDay

SYNTAX ERROR. what could this be ? thanks


Report •

#13
July 1, 2013 at 11:06:10
That's wierd that it pasted into the forum like that. It doesn't look like that in my VBA editor.

Anyway, that should be 2 separate lines. Place your cursor at the end of this and press Enter:

= empNamesItems(numGrps - 1)

You should get this and then be OK:

    Sheets(2).Range("B" & startRw & ":B" & startRw + lastDay - 1) _
                      = empNamesItems(numGrps - 1)
         startRw = startRw + lastDay

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

Ask Question