VBA: Insert new row based on cell value & modify previous row

L

laurie9300

New Member
Joined
Jan 30, 2017
Messages
9
I've been a VBA hack for a few years now, and have always managed find and modify code as needed, and learn a little along the way, until now.

I'm doing a large amount of processing over 2 worksheets, and this last step has me confuddled. I have found some code that does each step, but cannot seem to marry them all together.

This processing needs to be done on "Sheet1"

There are 2 values involved and I need to step through all rows:

Date values in Column J
Labour minutes (integer) in Column Q

Each row needs to represent 1 workday of 426 minutes, but some jobs have more than 426 minutes allocated. I need to find and duplicate these rows modifying the labour minutes and date as I go.

If the value in Column Q < 426 - do nothing

If the value in Column Q > 426 - copy the row and paste it underneath - subtract 426 from the original row - in the new row Q = 426 and subtract 1 workday from J in the new row

Before:



After:



Adding new columns for the date or labour is not a problem, nor is the row order as the data is being referenced in another sheet.

Any help will be greatly appreciated..................
 

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.
Sort by date Sort by votes
try this

Code: 
Sub t()
With ActiveSheet
Dim rw As Long, v As Long, r As Integer, i As Long
    For rw = .Cells(Rows.Count, 17).End(xlUp).Row To 2 Step -1
        If .Cells(rw, 17).Value >= 426 Then
            v = Cells(rw, 17).Value
            If v Mod 426 > 0 Then
                r = Int(v / 426)
                .Cells(rw, 17).Offset(1).Resize(r).EntireRow.Insert
                .Cells(rw, 17).Offset(1).Resize(r) = 426
                .Cells(rw, 17) = v Mod 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            Else
                r = Int(v / 426)
                .Cells(rw, 17).Offset(1).Resize(r - 1).EntireRow.Insert
                .Cells(rw, 17).Offset(1).Resize(r - 1) = 426
                .Cells(rw, 17) = 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            End If
        End If
    Next
End With
End Sub
 
Upvote 0
JLGWhiz said:
try this

Code: 
Sub t()
With ActiveSheet
Dim rw As Long, v As Long, r As Integer, i As Long
    For rw = .Cells(Rows.Count, 17).End(xlUp).Row To 2 Step -1
        If .Cells(rw, 17).Value >= 426 Then
            v = Cells(rw, 17).Value
            If v Mod 426 > 0 Then
                r = Int(v / 426)
                .Cells(rw, 17).Offset(1).Resize(r).EntireRow.Insert
                .Cells(rw, 17).Offset(1).Resize(r) = 426
                .Cells(rw, 17) = v Mod 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            Else
                r = Int(v / 426)
                .Cells(rw, 17).Offset(1).Resize(r - 1).EntireRow.Insert
                .Cells(rw, 17).Offset(1).Resize(r - 1) = 426
                .Cells(rw, 17) = 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            End If
        End If
    Next
End With
End Sub
Click to expand...

Thank you JLGWhiz, you are indeed a Whiz!

This is almost where I need it to be, and if it's all I've got, I will make do, however there are a couple of things not quite right.

1. The inserted rows are empty, except for the J & Q values. Granted these are the ones I need, however a "Copy complete Row and insert below" would be preferable.

2. The Date field (column J) is successfully subtracting 1 day from the date above, however I would prefer if it was subtracting 1 "workday or weekday". (would the WORKDAY function be suitable in some way?)

Thank you again for the time and effort donated to educate us "hacks"
 
Upvote 0
laurie9300 said:
Thank you JLGWhiz, you are indeed a Whiz!

This is almost where I need it to be, and if it's all I've got, I will make do, however there are a couple of things not quite right.

1. The inserted rows are empty, except for the J & Q values. Granted these are the ones I need, however a "Copy complete Row and insert below" would be preferable.

2. The Date field (column J) is successfully subtracting 1 day from the date above, however I would prefer if it was subtracting 1 "workday or weekday". (would the WORKDAY function be suitable in some way?)

Thank you again for the time and effort donated to educate us "hacks"
Click to expand...

I would need to be able to see an image of your worksheet to accomodate those items. Or, get a detailed narrative of the sheet layout so VBA can be told where to look for data and what to do with it.
 
Upvote 0
See if this version is more to your liking.
Code: 
Sub t2()
With ActiveSheet
Dim rw As Long, v As Long, r As Integer, i As Long
    For rw = .Cells(Rows.Count, 17).End(xlUp).Row To 2 Step -1
        If .Cells(rw, 17).Value >= 426 Then
            v = Cells(rw, 17).Value
            If v Mod 426 > 0 Then
                r = Int(v / 426)
                .Cells(rw, 17).Offset(1).Resize(r).EntireRow.Insert
                .Range("A" & rw + 1).Resize(r).EntireRow = .Range(.Cells(rw, 1), .Cells(rw, Columns.Count).End(xlToLeft)).Value
                .Cells(rw, 17).Offset(1).Resize(r) = 426
                .Cells(rw, 17) = v Mod 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            Else
                r = Int(v / 426)
                .Cells(rw, 17).Offset(1).Resize(r - 1).EntireRow.Insert
                .Range("A" & rw + 1).Resize(r).EntireRow = .Range(.Cells(rw, 1), .Cells(rw, Columns.Count).End(xlToLeft)).Value
                .Cells(rw, 17).Offset(1).Resize(r - 1) = 426
                .Cells(rw, 17) = 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            End If
        End If
    Next
End With
End Sub
 
Upvote 0
See if this works better

Code: 
Sub t3()
With ActiveSheet
Dim rw As Long, v As Long, r As Integer, i As Long
    For rw = .Cells(Rows.Count, 17).End(xlUp).Row To 2 Step -1
        If .Cells(rw, 17).Value >= 426 Then
            v = Cells(rw, 17).Value
            If v Mod 426 > 0 Then
                r = Int(v / 426)
                .Cells(rw, 17).Offset(1).Resize(r).EntireRow.Insert
                .Range ("A" & rw + 1), .Resize(r, .UsedRange.Columns.Count) = .Range(.Cells(rw, 1), .Cells(rw, Columns.Count).End(xlToLeft)).Value
                .Cells(rw, 17).Offset(1).Resize(r) = 426
                .Cells(rw, 17) = v Mod 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            Else
                r = Int(v / 426)
                If r > 1 Then
                    .Cells(rw, 17).Offset(1).Resize(r - 1).EntireRow.Insert
                End If
                .Range("A" & rw + 1).Resize(r, .UsedRange.Columns.Count) = .Range(.Cells(rw, 1), .Cells(rw, Columns.Count).End(xlToLeft)).Value
                .Cells(rw, 17).Offset(1).Resize(r - 1) = 426
                .Cells(rw, 17) = 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            End If
        End If
    Next
End With
End Sub

The other one was producing a bunch of #N/A errors because there was no data for those cells. This one might produce a couple, but those can be ignored and deleted.
 
Last edited:
Upvote 0
JLGWhiz said:
See if this works better

Code: 
Sub t3()
With ActiveSheet
Dim rw As Long, v As Long, r As Integer, i As Long
    For rw = .Cells(Rows.Count, 17).End(xlUp).Row To 2 Step -1
        If .Cells(rw, 17).Value >= 426 Then
            v = Cells(rw, 17).Value
            If v Mod 426 > 0 Then
                r = Int(v / 426)
                .Cells(rw, 17).Offset(1).Resize(r).EntireRow.Insert
                .Range ("A" & rw + 1), .Resize(r, .UsedRange.Columns.Count) = .Range(.Cells(rw, 1), .Cells(rw, Columns.Count).End(xlToLeft)).Value
                .Cells(rw, 17).Offset(1).Resize(r) = 426
                .Cells(rw, 17) = v Mod 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            Else
                r = Int(v / 426)
                If r > 1 Then
                    .Cells(rw, 17).Offset(1).Resize(r - 1).EntireRow.Insert
                End If
                .Range("A" & rw + 1).Resize(r, .UsedRange.Columns.Count) = .Range(.Cells(rw, 1), .Cells(rw, Columns.Count).End(xlToLeft)).Value
                .Cells(rw, 17).Offset(1).Resize(r - 1) = 426
                .Cells(rw, 17) = 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            End If
        End If
    Next
End With
End Sub

The other one was producing a bunch of #N/A errors because there was no data for those cells. This one might produce a couple, but those can be ignored and deleted.
Click to expand...

Thank you again! I was just playing with the previous one........

I've also been researching the WORKDAY function (a bit). I'm guessing I'll have to replace:

Code: 
For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i

....in both places
 
Upvote 0
JLGWhiz said:
See if this works better

Code: 
Sub t3()
With ActiveSheet
Dim rw As Long, v As Long, r As Integer, i As Long
    For rw = .Cells(Rows.Count, 17).End(xlUp).Row To 2 Step -1
        If .Cells(rw, 17).Value >= 426 Then
            v = Cells(rw, 17).Value
            If v Mod 426 > 0 Then
                r = Int(v / 426)
                .Cells(rw, 17).Offset(1).Resize(r).EntireRow.Insert
                .Range ("A" & rw + 1), .Resize(r, .UsedRange.Columns.Count) = .Range(.Cells(rw, 1), .Cells(rw, Columns.Count).End(xlToLeft)).Value
                .Cells(rw, 17).Offset(1).Resize(r) = 426
                .Cells(rw, 17) = v Mod 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            Else
                r = Int(v / 426)
                If r > 1 Then
                    .Cells(rw, 17).Offset(1).Resize(r - 1).EntireRow.Insert
                End If
                .Range("A" & rw + 1).Resize(r, .UsedRange.Columns.Count) = .Range(.Cells(rw, 1), .Cells(rw, Columns.Count).End(xlToLeft)).Value
                .Cells(rw, 17).Offset(1).Resize(r - 1) = 426
                .Cells(rw, 17) = 426
                For i = 1 To r
                    .Cells(rw, 17).Offset(i, -7) = .Cells(rw, 17).Offset(, -7).Value - i
                Next
            End If
        End If
    Next
End With
End Sub

The other one was producing a bunch of #N/A errors because there was no data for those cells. This one might produce a couple, but those can be ignored and deleted.
Click to expand...

This one doesn't work.......

Run-time error 438 - Object doesn't support this property or method - on this line:

Code: 
 .Range ("A" & rw + 1), .Resize(r, .UsedRange.Columns.Count) = .Range(.Cells(rw, 1), .Cells(rw, Columns.Count).End(xlToLeft)).Value
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Solved
VBA - Match two values from Table1 to two in Table2 and move/align
2
Replies
15
Views
377
Welshy1491
W
M
  • Solved
Insert new row with incremental formula
Replies
8
Views
711
Sheik
S
bizzyizzy215
  • Question Question
A VBA that inserts an image into the actual cell
Replies
1
Views
70
saboh12617
S
R
  • Question Question
VBA Inserting rows based on Column criteria
Replies
4
Views
107
myall_blues
myall_blues
C
  • Question Question
Create a new row for every date in row and create multiple copies of data to new worksheet based on cell number value for each date in the row VBA
Replies
0
Views
32
Chris258
C

Forum statistics

Threads
1,224,824
Messages
6,181,187
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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