[URGENT] Insert row based on day/time and then add text

george4884

New Member
Joined
Mar 16, 2014
Messages
6
Hi All,

I'm struggling with this situation described below:

If the day/time on Column B and Column C falls outside the criteria shown below, then I need to insert a row before the next non blank cell, and insert the word "QUERY" in Column D.

Criteria:

Monday - Friday, 08:00 until 17:00
Saturday, 08:00 until 13:00
Sunday, 08:00 until 11:00

I have made a dummy data below to illustrate how my spreadsheet looks like. My original spreadsheet >5000 rows of data.

Original data before modification:

Column AColumn BColumn CColumn D
110003458/3/201407:30WGFH2



IJLKS



KJB4HL



KJBKLB
110003468/3/201408:50FEHWJ
110003479/3/201411:24GHJHO



KSBJLK
110003489/3/201418:13DFHYK



KJLBK5



KLJBLK



KKLJ90
110003499/3/201419:30KJBFJ



SGEBE



DGGT
1100035010/3/201406:45KLNKJ
1100035110/3/201407:38JHSBN



RHTYH
1100035210/3/201408:15KJSN9



HRH53



DTHT4
1100035310/3/201417:31JGLIO



SGEBE



DFHYK

<tbody>
</tbody>

This is how I want it to be modified:

Column AColumn BColumn CColumn D
110003458/3/201407:30WGFH2



IJLKS



KJB4HL



KJBKLB



QUERY
110003468/3/201408:50FEHWJ
110003479/3/201410:24GHJHO



KSBJLK
110003489/3/201418:13DFHYK



KJLBK5



KLJBLK



KKLJ90



QUERY
110003499/3/201419:30KJBFJ



SGEBE



DGGT



QUERY
1100035010/3/201406:45KLNKJ



QUERY
1100035110/3/201407:38JHSBN



RHTYH



QUERY
1100035210/3/201408:15KJSN9



HRH53



DTHT4
1100035310/3/201417:31JGLIO



SGEBE



DFHYK



QUERY

<tbody>
</tbody>

Hope someone could help me on this...

File format: Ms Excel 97-2003 (*.xls), Windows 7/8

Thanks!
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Not sure how fast this will run, but seems to match your result.
Code:
Sub insert_row()
    lastrow = Cells.Find(what:="*", searchdirection:=xlPrevious).Row
    num_dates = WorksheetFunction.CountA(Range(Range("B1"), Range("B" & lastrow))) 'subtract any number of headers that exist in B
    Range("B1").Select 'set to first date cell in column B
        For i = 1 To num_dates - 1
            Select Case WorksheetFunction.Weekday(ActiveCell, 2) 'pick day of week
                Case 1 To 5
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 17 Then _
                    GoTo AddRow
                Case 6
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 13 Then _
                    GoTo AddRow
                Case 7
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 11 Then _
                    GoTo AddRow
           End Select
            ActiveCell.End(xlDown).Select
            GoTo Skipover
AddRow:
                ActiveCell.End(xlDown).EntireRow.Insert
                ActiveCell.End(xlDown).Offset(-1, 2).Value = "QUERY"
                ActiveCell.End(xlDown).Select
Skipover:
        Next i
    'Handle the very last date
            Select Case WorksheetFunction.Weekday(ActiveCell, 2) 'pick day of week
                Case 1 To 5
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 17 Then _
                    GoTo AddQuery
                Case 6
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 13 Then _
                    GoTo AddQuery
                Case 7
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 11 Then _
                    GoTo AddQuery
           End Select
        Exit Sub
AddQuery:
    On Error GoTo AddQuery2
                ActiveCell.Offset(0, 2).End(xlDown).Offset(1, 0).Value = "QUERY"
        Exit Sub
AddQuery2:
                ActiveCell.Offset(1, 2).Value = "QUERY"
End Sub
 
Upvote 0
Hi C Moore,

Appreciate your time on this. That code is certainly far different than what I imagined it would be - its just brilliantly short.

However, it returns an error when I tried to run it: Compile error: End Select without Select Case

Also, I'm sorry because I've missed to describe the following details in my first post:
  1. The date is copied down until the next episode - I've copied part of my actual data below.
  2. There's an exception to the criteria: I don't need to add the text "QUERY" for all episodes that has the code "KSHL7" in Column D.

Example data:

11980994
8/3/2014
12:37:33
SZJ0QP
11980995
8/3/2014
12:40:49
SZJ0
8/3/2014
OIVV5
8/3/2014
8EA
8/3/2014
IJVO
11980997
8/3/2014
12:50:15
SZJ0QPV
8/3/2014
8AASD
8/3/2014
OIVV5
8/3/2014
8EA
8/3/2014
IJVO
11980998
8/3/2014
12:55:09
V7HV
11980999
8/3/2014
12:56:18
SZJ0QPV
8/3/2014
8ATYZ
8/3/2014
8A8NS
8/3/2014
8AASD
11987600
8/3/2014
12:58:03
VBA18
11987601
8/3/2014
12:59:11
L7HP
11987602
8/3/2014
13:00:32
SZJ0
8/3/2014
VBA18
11987603
8/3/2014
13:10:38
SZJ0QPV
8/3/2014
V7HV
11987604
8/3/2014
13:14:25
SZJ0
11987605
8/3/2014
13:02:34
KSHL7
11987606
8/3/2014
13:05:49
KSHL7
11987607
8/3/2014
14:44:20
L7HP
8/3/2014
11987608
8/3/2014
14:42:42
SSO8SO
11987609
8/3/2014
16:06:06
SZJ0
11987610
8/3/2014
16:07:23
WESW
11987611
8/3/2014
16:08:58
SZJ0
11987612
8/3/2014
16:10:05
SZJ0
11987613
8/3/2014
16:12:06
KSHL7
11987614
8/3/2014
16:13:33
KSHL7
11987615
8/3/2014
16:52:15
ANAW
11987616
8/3/2014
16:53:25
SZJ02
8/3/2014
IJVO
11987617
8/3/2014
16:54:34
SZJ0VB
11987618
8/3/2014
16:56:01
SZJ0
11988313
8/3/2014
13:26:30
AMPV
11988314
8/3/2014
13:28:02
SSO8SO
11988315
8/3/2014
13:29:55
SSO8SO
11988316
8/3/2014
16:51:02
SZJ0
11988317
8/3/2014
16:52:20
ABO
11128864
8/3/2014
15:26:28
KSHL7
11128865
8/3/2014
15:25:29
KSHL7
11128866
8/3/2014
15:24:30
KSHL7
11128867
8/3/2014
15:23:45
KSHL7

<tbody>
</tbody>


Please advise what went wrong here. Many mant thanks in advance!
 
Upvote 0
Do you want the date where QUERY is added? And can you check the error? There should be one end select for each select, and as far as I can tell there is (ie runs for me with your sample data).
 
Upvote 0
Hi C Moore,

Yes, I need the date to be copied down when QUERY is added - thanks

I've checked my code and it's identical to yours. I'll explore why I'm getting compile error when running the code in my original spreadsheet. I'll check the cell formats as well.

However, when I tried your code on a fresh spreadsheet with the sample data I've provided here, I don't see the compile error now, but there is a new error: Run time error '1004': Application defined or object defined error and debug tool highlighted the following section of the code. I also noted that the last selected cell was B65536 and "QUERY" was added in cell D65535.

Code:
AddQuery2:
                ActiveCell.Offset(1, 2).Value = "QUERY" 'debug tool highlited this row
 
Upvote 0
Hi C Moore,

I hope you can help me with this soon. I tried to modify the code but no success so far.

Thanks.
 
Upvote 0
I haven't modified it for the one other exception, but this will add the dates.
Code:
 Sub insert_row()
    lastrow = Cells.Find(What:="*", SearchDirection:=xlPrevious).Row
    num_dates = WorksheetFunction.CountA(Range(Range("B1"), Range("B" & lastrow))) 'subtract any number of headers that exist in B
    Range("B1").Select 'set to first date cell in column B
        For i = 1 To num_dates - 1
            Select Case WorksheetFunction.Weekday(ActiveCell, 2) 'pick day of week
                Case 1 To 5
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 17 Then _
                    GoTo AddRow
                Case 6
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 13 Then _
                    GoTo AddRow
                Case 7
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 11 Then _
                    GoTo AddRow
           End Select
            ActiveCell.End(xlDown).Select
            GoTo Skipover
AddRow:
                ActiveCell.End(xlDown).EntireRow.Insert
                ActiveCell.End(xlDown).Offset(-1, 2).Value = "QUERY"
                ActiveCell.End(xlDown).Select
Skipover:
        Next i
    'Handle the very last date
            Select Case WorksheetFunction.Weekday(ActiveCell, 2) 'pick day of week
                Case 1 To 5
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 17 Then _
                    GoTo AddQuery
                Case 6
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 13 Then _
                    GoTo AddQuery
                Case 7
                    If ActiveCell.Offset(0, 1) * 24 < 8 Or ActiveCell.Offset(0, 1) * 24 > 11 Then _
                    GoTo AddQuery
           End Select
        GoTo AddDates
AddQuery:
    On Error GoTo AddQuery2
                ActiveCell.Offset(0, 2).End(xlDown).Offset(1, 0).Value = "QUERY"
        GoTo AddDates
AddQuery2:
                ActiveCell.Offset(1, 2).Value = "QUERY"
AddDates:
    Range(Range("B1"), Range("D1").End(xlDown).Offset(0, -2)).Select
    Dim oRng As Range
    Set oRng = Selection
        oRng.SpecialCells(xlCellTypeBlanks).Select
        oRng.FormulaR1C1 = "=R[-1]C"
        oRng.Copy
        oRng.PasteSpecial Paste:=xlValues
End Sub
 
Upvote 0
I'm sorry. The code still doesn't work. I'm still getting Run time error '1004': Application defined or object defined error

I've uploaded my excel spreadsheet at this link: https://www.dropbox.com/s/wgdyntnafqhzo91/dummy1.xls

I hope someone can have look at it. I'm running out of time. Please help...


Dear MrExcellians...

Please help me to fix my code. I still could not get it working as intended.

Thanks.
 
Upvote 0
At this point, why not do the very last entry manually, its only one entry. In that case delete everything between headers Skipover: and AddDates: including the headers.
 
Upvote 0

Forum statistics

Threads
1,213,494
Messages
6,113,972
Members
448,537
Latest member
Et_Cetera

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top