Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Sub AccessTransfer()
- Range("A1:F1").Select
- Selection.Copy
- Sheets("Sheet2").Select
- ActiveSheet.Paste
- ActiveCell.Offset(0, 6).Value = "Oven"
- Range("A65536").End(xlUp).Offset(1, 0).Select
- Run.Application "Private Sub Worksheet_Change(ByVal Target As Range)"
- Sheets("Sheet1").Select
- Application.CutCopyMode = False
- End Sub
- Private Sub Worksheet_Change(ByVal Target As Range)
- If Application.CountIf(Range("A:A"), Target) > 1 Then
- MsgBox "Duplicate Entry", vbCritical, "Remove Data"
- Target.Value = ""
- End If
- Range("A65536").End(xlUp).Offset(1, 0).Select
- End Sub
- With Sheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0)
- .Value = .Value
- End With
- Sub AccessTransfer()
- Dim shtSrc As Worksheet, shtDest As Worksheet
- Dim v, c As Range
- Set shtSrc = ActiveSheet
- Set shtDest = ThisWorkbook.Sheets("Sheet2")
- v = shtSrc.Range("A1").Value 'value to check...
- If Application.CountIf(shtDest.Range("A:A"), v) > 0 Then
- MsgBox "Value '" & v & "' already exists!", vbCritical, "Can't Transfer!"
- Else
- 'OK to copy over...
- Set c = shtDest.Range("A65536").End(xlUp).Offset(1, 0)
- shtSrc.Range("A1:F1").Copy c
- c.Offset(0, 6).Value = "oven"
- End If
- Application.CutCopyMode = False
- End Sub
- Sub AccessTransfer()
- With Worksheets("Sheet2")
- Worksheets("Sheet1").Range("A1:F1").Copy _
- Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
- 'Sheet2's Worksheet_Change has been triggered right here
- 'check if the action has been reversed
- If Not IsEmpty(.Cells(.Rows.Count, "A").End(xlUp)) Then
- 'turn off events for the Oven value write
- Application.EnableEvents = False
- .Cells(.Rows.Count, "A").End(xlUp).Offset(0, 6) = "Oven"
- 'turn events back on
- Application.EnableEvents = True
- End If
- End With
- End Sub
- Option Explicit
- Private Sub Worksheet_Change(ByVal Target As Range)
- If Not Intersect(Target, Range("A:A")) Is Nothing Then
- On Error GoTo bm_Safe_Exit
- Application.EnableEvents = False
- Dim c As Long, rngs As Range
- Set rngs = Intersect(Target, Range("A:A"))
- For c = rngs.Count To 1 Step -1
- If Application.CountIf(Columns("A"), rngs(c)) > 1 Then
- MsgBox "Duplicate Entry in " & rngs(c).Address(0, 0), _
- vbCritical, "Remove Data"
- rngs(c).EntireRow.Delete
- End If
- Next c
- End If
- bm_Safe_Exit:
- Application.EnableEvents = True
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement