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

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
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

M
  • Solved
Insert new row with incremental formula
Replies
8
Views
585
Sheik
S
C
  • Question Question
Copy Path Down to Next Row but Change Workbook Name
Replies
9
Views
363
etaf
etaf
P
  • Question Question
TypeScript (or other solutions) for modifying given list of cells (and similar problems)
Replies
0
Views
93
Pingaware
P
K
  • Question Question
VBA to insert new row if cell contains certain symbol
Replies
1
Views
264
Sequoyah
Sequoyah
N
  • Question Question
Spitting every 2000 rows of data to new workbook based on duplicate value
Replies
1
Views
82
Skyybot
Skyybot

Forum statistics

Threads
1,223,909
Messages
6,175,312
Members
452,634
Latest member
cpostell

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