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