code not to copy formula

[peter renton]

Hi All

Can somebody help me with this

i have a code in sheet 2 that when a y is entered into column m it copies that row into sheet 3
but it also copies the formula aswell,
In sheet 1 the data will be auto deleted when a date is reached but this would also delete the data in
sheet 3 because its still looking at the formula, how can i get araound this?

The data in sheet 2 is just mirrored from sheet 1 which when the data in sheet 1 is deleted would leave
blank rows in sheet 2 is there a way around this to ??


Any help would be appreciated

Peter

[Trebor76]

Hi Peter,

Try this which copies the range from SHEET2 to Sheet3 as values:


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim tRow As Long
Dim nRow As Long

If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("M:M")) Is Nothing Then 'adjust for check column
If UCase(Target.Value) = "Y" Then
Set ws1 = Worksheets("SHEET2")
Set ws2 = Worksheets("Sheet3")
tRow = Target.Row
nRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
Application.ScreenUpdating = False
ws1.Range("A" & tRow).Resize(, 9).Copy
ws2.Range("A" & nRow).PasteSpecial xlPasteValues '(, 8) adjust for # columns to copy
Application.CutCopyMode = False
Set ws1 = Nothing
Set ws2 = Nothing
Application.ScreenUpdating = True
End If
End If

End Sub

HTH

Robert

[peter renton]

Thanks Robert that works great..

Is there a way to get it so that when i put a cost in the ist service cell and copy it copies to sheet 3 and then when i enter a cost in 2nd service it will add this data or copy over the same row uning the reg as a unique number

peter

[Trebor76]

Hi Peter,

Try this:


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim tRow As Long
Dim nRow As Long

If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("M:M")) Is Nothing Then 'adjust for check column
If UCase(Target.Value) = "Y" Then
Set ws1 = Worksheets("SHEET2")
Set ws2 = Worksheets("Sheet3")
tRow = Target.Row
If InStr(CStr(ws2.Name), " ") > 0 Then 'Need single quote if tab name has a space
On Error Resume Next 'Account for no match
nRow = Evaluate("MATCH(B5,'" & CStr(ws2.Name) & "'!B:B,0)")
On Error GoTo 0
Else
On Error Resume Next 'Account for no match
nRow = Evaluate("MATCH(B5," & CStr(ws2.Name) & "!B:B,0)")
On Error GoTo 0
End If
If nRow = 0 Then
nRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
Application.ScreenUpdating = False
ws1.Range("A" & tRow).Resize(, 9).Copy
ws2.Range("A" & nRow).PasteSpecial xlPasteValues '(, 8) adjust for # columns to copy
Application.CutCopyMode = False
Set ws1 = Nothing
Set ws2 = Nothing
Application.ScreenUpdating = True
End If
End If

End Sub

Regards,

Robert

[peter renton]

Hi Robert

I have attached an updated file

i am tring to have certain cell data copied into summary sheet so that the rows can be filtered and these can be calculated to show profit/loss .

At the moment sheet one holds the imputted data and sheet two mirrors certain cells from sheet 1
sheet 3 copies the data from sheet 2 without the formula, so its not deleted when the rows in sheet 1 are (on the full wb there is and auto delete/cleanse
function to delete rows 12 months after contract has ended)

what i would like is the imput data to be copied into a sheet (like sheet4) and not have the other sheets so that it can be updated when additional costs are imputed(via the unique reg number) but not deleted when the imput row goes and i can then filter data and cost up the filteed data.

at the moment if i use the find blank row code that is in sheet 2 for sheet 4 it enters it blow the grid (the cells are not empty)

could the code only look at the next blank cell in column A so it would not check the other cells that have forular in them?

Could the data be copied automatic instead of telling when by entering y, the full wb checks and updates when it is opened, or before it closes would be ok or as the data is typed

there would also be a second shet the same as sheet 1 that would need its data copying into sheet 4

hope i have explained this ok ??

I have tried and failed to tweak the coding to do what i need

If you have a better way to complete this task i would be very interested to know.
Thank you

Peter

[Trebor76]

Hi Peter,

Try this - just not sure what you want in column G of Sheet4. As entries only with a reg number in column B of SHEET1 are copied over to to Sheet4, row 8 is ignored. I've included some notes to help show you what the code is doing.

If this isn't right I'd suggested starting a new thread as you're original question has been answered and what you're now asking for is now totally different.

Regards,

Robert


Option Explicit
Sub Macro1()

Const lngStartRow As Long = 3 'Commencement row number for data. Change to suit.

Dim lngEndRow As Long
Dim rngCell As Range
Dim lngMyRow As Long
Dim ws1 As Worksheet, _
ws2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = Worksheets("SHEET1")
Set ws2 = Worksheets("Sheet4")

lngEndRow = ws1.Range("A:M").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'Find the last row in ws1 from columns A to M (inclusive)

For Each rngCell In ws1.Range("B" & lngStartRow & ":B" & lngEndRow)
'If there's a reg number in column B of the current row, then...
If Len(rngCell) > 0 Then
On Error Resume Next
'...try and find if it's already been copied to Sheet4
lngMyRow = 0 'Initialise variable
'Note if the reg number becomes numeric, you'll need to remove the double quotation marks around rngCell
lngMyRow = Evaluate("MATCH(""" & rngCell & """," & CStr(ws2.Name) & "!B:B,0)")
On Error GoTo 0
'If the reg number is already in Sheet4 then...
If lngMyRow <> 0 Then
'...link the data from SHEET1 to the applicable row in Sheet4
ws2.Range("A" & lngMyRow).Value = ws1.Range("A" & rngCell.Row).Value
ws2.Range("B" & lngMyRow).Value = ws1.Range("B" & rngCell.Row).Value
ws2.Range("C" & lngMyRow).Value = ws1.Range("E" & rngCell.Row).Value
ws2.Range("D" & lngMyRow).Value = ws1.Range("F" & rngCell.Row).Value
ws2.Range("E" & lngMyRow).Value = ws1.Range("G" & rngCell.Row).Value
ws2.Range("F" & lngMyRow).Value = ws1.Range("H" & rngCell.Row).Value
ws2.Range("H" & lngMyRow).Formula = "=D" & lngMyRow & "-E" & lngMyRow
'Else...
Else
'...find the next available row in Sheet4 and then link the data from SHEET1 to that row.
lngMyRow = ws2.Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 'Find the last row in ws2 from columns A to H (inclusive) and increment this by 1
ws2.Range("A" & lngMyRow).Value = ws1.Range("A" & rngCell.Row).Value
ws2.Range("B" & lngMyRow).Value = ws1.Range("B" & rngCell.Row).Value
ws2.Range("C" & lngMyRow).Value = ws1.Range("E" & rngCell.Row).Value
ws2.Range("D" & lngMyRow).Value = ws1.Range("F" & rngCell.Row).Value
ws2.Range("E" & lngMyRow).Value = ws1.Range("G" & rngCell.Row).Value
ws2.Range("F" & lngMyRow).Value = ws1.Range("H" & rngCell.Row).Value
ws2.Range("H" & lngMyRow).Formula = "=D" & lngMyRow & "-E" & lngMyRow
End If
End If
Next rngCell

Application.ScreenUpdating = True

End Sub

Robert