daily pastebin goal
44%
SHARE
TWEET

Untitled

a guest Sep 21st, 2017 49 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub AccessTransfer()
  2. Range("A1:F1").Select
  3. Selection.Copy
  4. Sheets("Sheet2").Select
  5. ActiveSheet.Paste
  6. ActiveCell.Offset(0, 6).Value = "Oven"
  7. Range("A65536").End(xlUp).Offset(1, 0).Select
  8. Run.Application "Private Sub Worksheet_Change(ByVal Target As Range)"
  9.  
  10. Sheets("Sheet1").Select
  11.  
  12. Application.CutCopyMode = False
  13.  
  14. End Sub
  15.  
  16. Private Sub Worksheet_Change(ByVal Target As Range)
  17. If Application.CountIf(Range("A:A"), Target) > 1 Then
  18.     MsgBox "Duplicate Entry", vbCritical, "Remove Data"
  19.     Target.Value = ""
  20. End If
  21. Range("A65536").End(xlUp).Offset(1, 0).Select
  22. End Sub
  23.    
  24. With Sheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0)
  25.     .Value = .Value
  26. End With
  27.    
  28. Sub AccessTransfer()
  29.  
  30.     Dim shtSrc As Worksheet, shtDest As Worksheet
  31.     Dim v, c As Range
  32.  
  33.     Set shtSrc = ActiveSheet
  34.     Set shtDest = ThisWorkbook.Sheets("Sheet2")
  35.  
  36.     v = shtSrc.Range("A1").Value  'value to check...
  37.  
  38.     If Application.CountIf(shtDest.Range("A:A"), v) > 0 Then
  39.         MsgBox "Value '" & v & "' already exists!", vbCritical, "Can't Transfer!"
  40.     Else
  41.        'OK to copy over...
  42.        Set c = shtDest.Range("A65536").End(xlUp).Offset(1, 0)
  43.        shtSrc.Range("A1:F1").Copy c
  44.        c.Offset(0, 6).Value = "oven"
  45.     End If
  46.  
  47.     Application.CutCopyMode = False
  48.  
  49. End Sub
  50.    
  51. Sub AccessTransfer()
  52.     With Worksheets("Sheet2")
  53.         Worksheets("Sheet1").Range("A1:F1").Copy _
  54.             Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
  55.         'Sheet2's Worksheet_Change has been triggered right here
  56.  
  57.         'check if the action has been reversed
  58.         If Not IsEmpty(.Cells(.Rows.Count, "A").End(xlUp)) Then
  59.             'turn off events for the Oven value write
  60.             Application.EnableEvents = False
  61.             .Cells(.Rows.Count, "A").End(xlUp).Offset(0, 6) = "Oven"
  62.             'turn events back on
  63.             Application.EnableEvents = True
  64.         End If
  65.     End With
  66. End Sub
  67.    
  68. Option Explicit
  69.  
  70. Private Sub Worksheet_Change(ByVal Target As Range)
  71.     If Not Intersect(Target, Range("A:A")) Is Nothing Then
  72.         On Error GoTo bm_Safe_Exit
  73.         Application.EnableEvents = False
  74.         Dim c As Long, rngs As Range
  75.         Set rngs = Intersect(Target, Range("A:A"))
  76.         For c = rngs.Count To 1 Step -1
  77.             If Application.CountIf(Columns("A"), rngs(c)) > 1 Then
  78.                 MsgBox "Duplicate Entry in " & rngs(c).Address(0, 0), _
  79.                     vbCritical, "Remove Data"
  80.                 rngs(c).EntireRow.Delete
  81.             End If
  82.         Next c
  83.     End If
  84. bm_Safe_Exit:
  85.     Application.EnableEvents = True
  86. End Sub
RAW Paste Data
Top