PDA

View Full Version : Solved: Code Deletes headers on .ClearContents



MDY
11-04-2007, 10:43 PM
Hi All,
Thanks for helping me out with this spread sheet. It is much appreciated.

How the Counts Sheet Works:
When we enter the a number into the field "Counts B3" the text from the cell "C3" will be copied that number of times into "Vegetable Details".

Current Errors and Problems.
The code almost works perfectly but when refreshing, the code will delete the headers of the sheet "Vegetable Details" unless there is already text in row B4. To see the error occur first delete all text from "Vegetable Details B4" onwards then enter a number in "Counts B3". The Headers will now be cleared and the text will begin at the top of the screen.

How am I able to stop the .ClearContents function from deleting the headers in this instance?


Possibilities: Using an if Statement Stops it from deleting the headers but repeats the entries for each cell instead of just refreashing the data.

'Code to Copy and paste Vegetable Details
Private Sub Worksheet_Change(ByVal Target As Range)



If Target.Column = 2 Then
With Sheets("Vegetable Details") 'Selects Sheet Vegetables
If c4 <> "" Then .Range(.Cells(4, 2), .Cells(Rows.Count, 2).End(xlUp)).ClearContents 'Clears Data for the Given Rows
For Each cel In Sheets("Counts").Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp)) 'Selects Text to Copy
If cel.Offset(, 1) <> "" Then
.Cells(Rows.Count, 2).End(xlUp).Offset(1).Resize(cel.Offset(, 1)) = cel
End If
Next
End With
Else

End If
Exits:

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

MDY
11-07-2007, 03:03 PM
Hi All,
Is anyone able to help me out on this one?

Thanks

figment
11-07-2007, 03:20 PM
try this

Private Sub Worksheet_Change(ByVal Target As Range)



If Target.Column = 2 Then
With Sheets("Vegetable Details") 'Selects Sheet Vegetables
.Range(.Cells(4, 2), .Cells(4, 2).End(xlDown)).ClearContents 'Clears Data for the Given Rows
For Each cel In Sheets("Counts").Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp)) 'Selects Text to Copy
If cel.Offset(, 1) <> "" Then
.Cells(Rows.Count, 2).End(xlUp).Offset(1).Resize(cel.Offset(, 1)) = cel
End If
Next
End With

Else

End If
Exits:

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

MDY
11-07-2007, 05:31 PM
Thanks Figment!!!
Your solution works perfectly. I've been trying to get this one right for some time with help from others (MDMackillop) and thank you all very much for helping me with this solution.

Cheers

MDY