Copy Rows based on cell value!

[dgt]

Hi all

I am in the process of re-vamping my primary workbook in order to make it more efficient and speed up the processing at the same time.

This has led to a new problem in that I need to create a sort of history list as per the 'Results' worksheet in the attached workbook.

As you will see I have made it work by inserting a number of rows with formulas that are blank unless the value in Column A is present. However, it would be better if the number of required rows could be inserted automatically based upon the value in B4, plus an additional blank row at the end to allow for future data/additions to the worksheet.

Row 7 will always be constant as there will always be at least one row to be filled. All of the formulas in Row 8 can be copied down to create the subsequent number of required rows.

I think a VBA solution is the only answer but not sure how to make it can be done. I have found a few examples on various sites but none of them work as per my requirements.

TIA ...David

[Bob Phillips]

Private Sub Workbook_Open()
Range("A8").Value = 2
Range("A7:A8").AutoFill Range("A7").Resize(Range("B4").Value)
Range("B7:J7").AutoFill Range("B7:J7").Resize(Range("B4").Value)
Application.CalculateFull
End Sub


This is workbook event code.
To input this code, right click on the Excel icon on the worksheet
(or next to the File menu if you maximise your workbooks),
select View Code from the menu, and paste the code

[dgt]

Hi xld

Thanks for the quick response but the code is not working correctly.

I deleted all of the rows after Row 7 and added the code to the workbook, see attached workbook #2.

However, whatever the results in B4, the code adds 8 rows whether it is more or less than the value in B4. e.g. When 1097548 is selected in B2 it should just display 1 result but actually displays the same result 9 times.

A minor quirk is that the number in column A changes formatting every other row, which is a bit odd. This may be resolved by formatting the cells but I have left this as it is for the moment, so you can see what happens.

I just re-loaded the file again and it came up with an error message, and when I run Debug it highlights:


Range("A7:A8").AutoFill Range("A7").Resize(Range("B4").Value)


Hope you can resolve this ...David

[mohanvijay]

See Attached

[dgt]

mohanvijay

Thanks for your efforts but it was not my intention to produce a list of every client in that fashion.

If it was applied to the real workbook, it would produce a result of at least 5000+ rows; however I need to experiment further with your code as it may be useable in different circumstances.

Regards ...David

[Bob Phillips]

Change you current event code with this



Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long

If Target.Address = "$B$2" Then

With Me

LastRow = .Range("A7").End(xlDown).Row
.Range("A8").Resize(LastRow - 7, 10).ClearContents
If .Range("B4").Value > 1 Then

.Range("A8").Value = 2
.Range("A7:A8").AutoFill .Range("A7").Resize(.Range("B4").Value)
.Range("B7:J7").AutoFill .Range("B7:J7").Resize(.Range("B4").Value)
End If
End With

Application.CalculateFull
End If

End Sub


and remove the original code that I supplied.

[dgt]

Hi xld

Sorry to tell you but it is still producing very wierd results, as the number of rows displayed does not match up with the number in B4.

It is almost as if the code is generating the number of rows based upon the calculated result of a different ID as selected in B2.

Have included the attachment with the new code applied to the worksheet.

Hope you can sort ...David

[Bob Phillips]

Can't see the p[roblem David, it seems to work perfectly to me.

[dgt]

Hi xld

Very puzzled by your reply as I still cannot get the code to produce the correct results.

For clarification, I have added an extra worksheet "Expected Results" which shows the correct list for each client in columns A to J.

In Columns L to U, I have copied the results that I get when using the code to produce the history list. In some instances I get differing results each time I change the ID in B2, especially when it is the 1st item on the Data Validation List.

By the way, I am running Office 2003 in case that is affecting the results.

David

[GTO]

Greetings David,

I hope this is of help and not hindrance, but I think I understand what you said at #7.

It appears to me that the COUNTIF in B4 does not update quickly enough, reference the changing val in B2. Thus, whatever the previous COUNTIF produced is what is used.

Anyways, if I got that right, here is Bob's code with forcing a quick calc on B4, before the results are needed in the code.


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long

If Target.Address = "$B$2" Then

Application.EnableEvents = False

Target.Offset(2).Calculate

With Me

LastRow = .Range("A7").End(xlDown).Row
.Range("A8").Resize(LastRow - 7, 10).ClearContents
If .Range("B4").Value > 1 Then

.Range("A8").Value = 2
.Range("A7:A8").AutoFill .Range("A7").Resize(.Range("B4").Value)
.Range("B7:J7").AutoFill .Range("B7:J7").Resize(.Range("B4").Value)
End If
End With

Application.EnableEvents = True

Application.CalculateFull

End If

End Sub

[dgt]

Hi GTO

You got it right, that amendment to Bobs code cured the problem; although I do not understand why it worked for Bob and not for me.

Thanks for both of your efforts to get this resolved so far.

However, there is one slight problem in that as the rows are being copied down, they are overwriting anything contained in the rows below. I assume that the code needs to insert the required of rows first before copying the range down.

Can this be done as there will be additional information added to the worksheet in the rows below, relating to the client ID in B2.

Thanks again ..David

[Bob Phillips]

Just remove the ClearContents line.

[dgt]

Hi xld

I removed the line


.Range("A8").Resize(LastRow - 7, 10).ClearContents


but this created more problems. Once you have selected the longest history (27 rows), everything then remains at 27 rows, no matter what the figure is in B4.

It also affects the automatic calculation as this appears to be more drawn out with this line of code removed.

Any other suggestions?

David

[Bob Phillips]

Sorry, I thought that that was what you wanted to happen.

[dgt]

xld

Might be the way I explained it that caused some confusion.

If you look at Example 1 in the attached workbook, it shows the Client who only has 1 row of added data; which is followed by a blank row, after which there is likely to be various lines of other information.

Currently when you run the code for another client, it will add the correct number of rows but it overwrites any data in the lines below; whereas it needs to maintain those rows on the sheet, whatever the selection, as shown in Example 2.

Hope this clarifies the situation.

David

[dgt]

<<< bump >>>

Would appreciate any assistance in resolving this problem ...thanks

[shrivallabha]

I have changed original code only at red part. To test it keep Row number 8 blank. Then run it and see if you need something on these lines.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long

If Target.Address = "$B$2" Then

Application.EnableEvents = False

Target.Offset(2, 0).Calculate

With Me

If .Range("A8").Value = "" Then
.Range("A8:J8").Resize(.Range("B4").Value - 1).Insert Shift:=xlDown

If .Range("B4").Value > 1 Then

.Range("A8").Value = 2
.Range("A7:A8").AutoFill .Range("A7").Resize(.Range("B4").Value)
.Range("B7:J7").AutoFill .Range("B7:J7").Resize(.Range("B4").Value)
End If

End If
End With

Application.EnableEvents = True

Application.CalculateFull

End If

End Sub

[dgt]

Hi Shrivallabha

Thanks for the amendment but sadly it only partially works.

I set it up with the smallest ID (list of 1 item), so that Row 8 is blank and some dummy data in rows 9 to 15.

On the 1st selection of a client, it changes correctly but all subsequent selections remain at the same length, irrespective of the figure in B4.

I have been trying to out various amendments using Offset, Row etc but none of them have worked :banghead:

This is proving much more complicated than I thought ...David

[shrivallabha]

I thought you'd need the row to be blank.

Or perhaps you want sledgehammer without conditions like this.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long

If Target.Address = "$B$2" Then

Application.EnableEvents = False

Target.Offset(2, 0).Calculate

With Me

.Range("A8:J8").Resize(.Range("B4").Value).Insert Shift:=xlDown

If .Range("B4").Value > 1 Then

.Range("A8").Value = 2
.Range("A7:A8").AutoFill .Range("A7").Resize(.Range("B4").Value)
.Range("B7:J7").AutoFill .Range("B7:J7").Resize(.Range("B4").Value)
End If

End With

Application.EnableEvents = True

Application.CalculateFull

End If

End Sub

[dgt]

Hi Shrivallabha

Sorry but that only made things worse.

Yes, I do need the row after the list to remain blank followed by the data that will be included with the worksheet, see Example 1 & 2 worksheets.

Your 1st code is in Results(2) & the last Code is in Results(3).

Whilst the 1st code maintains the blank row and subsequent lines of data; it somehow messes up the list that should be generated by B2 & B4.

I think the problem lies in the code as to whether the code reacts to the previous value in B4 or the changed value in B4 but I have no idea as to how to make it work correctly.

Still hopeful ...David

[dgt]

Hi all

Been working on that piece of code and have come up with the following solution that does partially work but needs refining by a VBA expert.


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
Dim i As Integer

If Target.Address = "$B$2" Then

Application.EnableEvents = False

Target.Offset(2).Calculate

With Me

For i = Cells(100, 1).End(xlUp).Row To 9 Step -1

If IsNumeric(Cells(i, 1)) Then
Cells(i, 1).EntireRow.Delete
End If
Next

If .Range("B4").Value > 1 Then
.Range("A8").Resize(.Range("B4").Value).EntireRow.Insert
.Range("A7:J7").AutoFill .Range("A7:J7").Resize(.Range("B4").Value)
End If

End With

Application.EnableEvents = True

Application.CalculateFull

End If

End Sub


My additions/modifications are shown in Red, not really sure if I have got this correct as when it runs, it seems a bit hesitant.

The main problem is that every time I change the Client ID to produce a new history list, the number of blank rows between the list and the rows of 'test data' increases by 1 row each time.

No idea why this is happening but hoping somebody here will be able to tidy up my code to make it work properly.

TIA ...David

[shrivallabha]

Hi,

I have few queries now. It somehow keeps getting circular.

1. The For loop would delete all the previous entries. XLD had previously used clearcontent. Is it not then the same as now?
Do you want to delete All entries that were existing?

2. If yes then with the clean slate why would you need insert.

3. Can you manually generate a complete result for say 4-5 runs so that one can understand where it is heading to and test the code against?

[dgt]

Hi Shrivallabha

I can understand that things have become a bit confusing but my original requirement has not changed.

In the attached workbook, I have applied my latest code to the results worksheet. Examples 1 to 5 are the actual results that should be displayed when selecting each of the Client IDs.

Although the final draft of the code from Xld correctly displayed the list of iterms for each ID, it was overwriting the rows of data that should appear underneath an individual history list.

I have now changed the value in A7 to a formula, so that all of the formulas in Row 7, will update themselves to the required data for each client, when copied down. As there will always be at least 1 result; then Row 7 can be left in permanently.

My thinking was that the number of rows to be deleted had to be from A8 downwards until the end of the list of entries before the blank row above the addtional data. I came across this piece of code which just deletes numeric rows and amended it accordingly to suit my worksheet.


Dim i as Integer

For i = Cells(100, 1).End(xlUp).Row To 9 Step -1

If IsNumeric(Cells(i, 1)) Then
Cells(i, 1).EntireRow.Delete
End If
Next


The next step was to insert the required number of rows, based upon the number in B4.


If .Range("B4").Value > 1 Then
.Range("A8").Resize(.Range("B4").Value).EntireRow.Insert
.Range("A7:J7").AutoFill .Range("A7:J7").Resize(.Range("B4").Value)
End If


However, I now realise that the problem with the extra row is due to the fact that the number of rows inserted should be reduced by 1 as the 1st row will always be A7. I have tried inserting "-1" into various places but nothing has worked so far.

My knowledge of VBA is very poor and I have got this far by experimenting with bits of code that I have across and trying to amend the original code as required.

I hope this clarifies the situation and that you can rectify this code or set up a better alternative.

Regards ...David

[shrivallabha]

For the first time, I think I have understood your requirement :bug: . See if this is what you are after. You have been very gritty throughout so never mind this isn't what you want. Let us know.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Dim LastRow As Long

If Target.Address = "$B$2" Then
Application.EnableEvents = False
Target.Offset(2).Calculate

With Me

If .Range("A8").Value <> "" Then 'Check Existence of data
LastRow = .Range("A7").End(xlDown).Row
For i = LastRow To 8 Step -1
If IsNumeric(Cells(i, 1)) Then
Cells(i, 1).EntireRow.Delete
End If
Next i
End If

If .Range("B4").Value > 1 Then
'Inserting 'B4 Value - 1' as autofill is from A7 but insertion from A8
.Range("A8").Resize(.Range("B4").Value - 1).EntireRow.Insert
.Range("A7:J7").AutoFill .Range("A7:J7").Resize(.Range("B4").Value)
End If

End With

Application.EnableEvents = True
Application.CalculateFull

End If

End Sub


I'm also attaching your last workbook ("results" worksheet code edited). Don't worry about your VBA skills, just keep visiting VBAExpress. At least that is what I do.

[dgt]

Hi Shrivallabha

Thanks for that update on the code. Only had time for a quick try out late last night and it seems to be working fine.

Not around now until the weekend; so will give you an update then.

Regards ...David

[dgt]

Hi Shrivallabha

Been experimenting with the revised code and it works correctly but it is very slow. This is especially noticeable with cell B2 which contains the Vlookup formula.

I am also puzzled as to why the "- 1" in your code works, as I tried using that in the very same place but all I got was error messages.


'Inserting 'B4 Value - 1' as autofill is from A7 but insertion from A8
.Range("A8").Resize(.Range("B4").Value - 1).EntireRow.Insert



Would like to know why for my own benefit.

Any ideas on speeding up the code.

Regards ...David

[shrivallabha]

Regarding the first part: The row insert always occurs from the selected row (A8) and pushes the specific row (A8) downwards for the specified amount of rows. We do not want to push our first (i.e. A7) down as it will be used for autofill.

However if we keep inserting from A8 with .Range("B4").Valuethen we will keep adding a row here and there. So to counter that it is set to .Range("B4").Value - 1.

Regarding code speed up, I do not know a lot. I am also learning VBA. However, I am adding the screen update part as it is one of the contributing member here (see the red marked part). This will tell excel that you are ONLY interested in the final output and not the whole evolution :devil2: .
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Dim LastRow As Long

If Target.Address = "$B$2" Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Target.Offset(2).Calculate

With Me

If .Range("A8").Value <> "" Then 'Check Existence of data
LastRow = .Range("A7").End(xlDown).Row
For i = LastRow To 8 Step -1
If IsNumeric(Cells(i, 1)) Then
Cells(i, 1).EntireRow.Delete
End If
Next i
End If

If .Range("B4").Value > 1 Then
'Inserting 'B4 Value - 1' as autofill is from A7 but insertion from A8
.Range("A8").Resize(.Range("B4").Value - 1).EntireRow.Insert
.Range("A7:J7").AutoFill .Range("A7:J7").Resize(.Range("B4").Value)
End If

End With

Application.EnableEvents = True
Application.CalculateFull
Application.ScreenUpdating = True
End If

End Sub

[dgt]

Shrivallabha

I think your knowledge of VBA is better than mine :bow: ; I tend to learn by experimenting with code and using examples that I have found similar to my requirments.

Unfortunately, adding the Application.ScreenUpdating lines only made things run much slower. I then realised that the main problem was with the line "Application.CalculateFull" which was re-calculating the entire workbook each time it runs. So I replaced this with "Me.Calculate" which made the changes work much quicker.


However if we keep inserting from A8 with .Range("B4").Valuethen we will keep adding a row here and there. So to counter that it is set to .Range("B4").Value - 1.

I understand the rationale for this; however I could not fathom out why this did not work for me, as this was the place that I tried using "- 1" in the code.

The final draft of the code is as follows:


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Dim LastRow As Long

If Target.Address = "$B$2" Then
Application.EnableEvents = False
Target.Offset(2).Calculate

With Me

If .Range("A8").Value <> "" Then 'Check Existence of data
LastRow = .Range("A7").End(xlDown).Row
For i = LastRow To 8 Step -1
If IsNumeric(Cells(i, 1)) Then
Cells(i, 1).EntireRow.Delete
End If
Next i
End If

If .Range("B4").Value > 1 Then
'Inserting 'B4 Value - 1' as autofill is from A7 but insertion from A8
.Range("A8").Resize(.Range("B4").Value - 1).EntireRow.Insert
.Range("A7:J7").AutoFill .Range("A7:J7").Resize(.Range("B4").Value)
End If

End With

Application.EnableEvents = True
Me.Calculate

End If

End Sub

This code is now producing the correct results; just a bit on the slow side still. Any more thoughts on this ...David

[ajn946946]

Did not work for me.

Edit: ignore, my mistake.

Cheers

[dgt]

<<< bump >>>

Can anyone assist with refining this code as it still seems to work quite slowly and with the additions of new formulas in the primary cells A7:J7, it is even more noticeable.

I think that I have made a slight improvement by moving the Me.Calculate to after the End If statement.


End With
Application.EnableEvents = True
End If
Me.Calculate
End Sub


Not sure if it is the correct procedure but it seems to have helped.

David