VBA code not working, have a sheet that copies contents of any unlocked cell to clipboard and want to change tab order

T

TheJay

Active Member
Joined
Nov 12, 2014
Messages
364
Office Version
  1. 2019
Platform
  1. Windows
I wonder if the tab order code needs to be incorporated into the "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" code, but when I tried that it created an infinite loop.

VBA Code: 
Option Explicit

Private Sub Worksheet_Activate()
    With Worksheets("Clipboard")
    MsgBox "Software relies heavily on the Windows clipboard." & Chr(13) & Chr(13) & "If you need to duplicate information to multiple accounts/properties, use this tool." & Chr(13) & Chr(13) & "Type the information needed, press ""Enter"" and then any cell you click on will automatically be copied to the clipboard.", vbInformation + vbOKOnly, "Automatic Clipboard"
         .Range("C4").Select
    End With
    With ActiveWindow
        .DisplayFormulas = False
        .DisplayHeadings = False
        .DisplayGridlines = False
        .DisplayHorizontalScrollBar = False
        .DisplayVerticalScrollBar = False
    End With
    With Application
        .DisplayFullScreen = True
        .DisplayFormulaBar = False
        .DisplayStatusBar = False
        .CommandBars("Full Screen").Visible = True
        .CommandBars("Worksheet Menu Bar").Enabled = False
        .CommandBars("Standard").Visible = False
        .CommandBars("Formatting").Visible = False
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("C4:C9,E4,E7")) Is Nothing Then
        Target.Copy
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tab As Variant
    Dim i As Long
    tab = Array("C4", "C5", "C6", "C7", "C8", "C9", "E4", "E7")
    Application.ScreenUpdating = False
    For i = LBound(tab) To UBound(tab)
        If tab(i) = Target.Address(0, 0) Then
            If i = UBound(tab) Then
                Me.Range(tab(LBound(tab))).Select
            Else
                Me.Range(tab(i + 1)).Select
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Also looking for a way to pause the copy function using a button to allow data to be copied into the worksheet from another source before re-enabling. So, perhaps an "Enable" and "Disable" button.
 
Last edited by a moderator:

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
Code has changed since original post made. Still need to resolve tabbing problem and ability to start and stop automatic clipboard copying.

ThisWorkbook updated:
VBA Code: 
Option Explicit

Private WithEvents oCbarEvents As CommandBars

#If VBA7 Then
Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long
#Else
Private Declare Function GetClipboardSequenceNumber Lib "user32" () As Long
#End If

Private Const TARGET_SHEET As String = "Clipboard"
Private Const TARGET_RANGE As String = "C7:C11,C13,C16,C19,C22,E7,E10,E13,E16,G13,G16"
Private Const TARGET_INFO_RANGE As String = "C4"

Private Sub Workbook_Open()
Set oCbarEvents = Application.CommandBars
Application.EnableEvents = False
Dim Sh As Worksheet
For Each Sh In Worksheets
If Sh.Name = "Property Numbering" Then
Sh.Protect UserInterFaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
Sh.Range("C14,C8").ClearContents
Sh.Range("B2").Value = "'Property Reference Guide (Click Arrow to Start)"
Sh.Range("C14,C8").Value = "'Choose"
ElseIf Sh.Name = "VO Areas" Then
Sh.Protect UserInterFaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
Sh.Range("C4").ClearContents
Sh.Range("C4").Value = "'Choose"
Else
Sh.Protect UserInterFaceOnly:=True
End If
Next
Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Set oCbarEvents = Application.CommandBars
End Sub

Private Sub oCbarEvents_OnUpdate()

Static lPrevSN As Long
   
Dim MyDataObject As Object
Dim lCutCopy As Long
Dim sClipText As String
   
If GetClipboardSequenceNumber <> lPrevSN Then
If Application.CutCopyMode <> False Then
With Sheets(TARGET_SHEET)
lCutCopy = Application.CutCopyMode
If Not Intersect(ActiveWindow.RangeSelection, .Range(TARGET_RANGE)) Is Nothing Then
Set MyDataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
MyDataObject.GetFromClipboard
sClipText = MyDataObject.GetText(1)
Mid(sClipText, Len(sClipText), 1) = vbNullChar
If InStr(sClipText, Chr(&HA)) Then
sClipText = Replace(sClipText, Chr(&H22), "")
End If
If .ProtectContents Then
 .Unprotect
.Range(TARGET_INFO_RANGE) = sClipText
 .Protect
End If
Set oCbarEvents = Nothing
If lCutCopy = 1 Then
ActiveWindow.RangeSelection.Copy
Else
ActiveWindow.RangeSelection.Cut
End If
Set oCbarEvents = Application.CommandBars
End If
End With
End If
End If
lPrevSN = GetClipboardSequenceNumber
End Sub

Clipboard Worksheet:
VBA Code: 
Option Explicit

Private Sub Worksheet_Activate()
    With Worksheets("Clipboard")
    MsgBox "Software relies heavily on the Windows clipboard." & Chr(13) & Chr(13) & "If you need to duplicate information to multiple accounts/properties, use this tool." & Chr(13) & Chr(13) & "Type the information needed, press ""Enter"" and then any cell you click on will automatically be copied to the clipboard.", vbInformation + vbOKOnly, "Automatic Clipboard"
         .Range("C4").Select
    End With
    With ActiveWindow
        .DisplayFormulas = False
        .DisplayHeadings = False
        .DisplayGridlines = False
        .DisplayHorizontalScrollBar = False
        .DisplayVerticalScrollBar = False
    End With
    With Application
        .DisplayFullScreen = True
        .DisplayFormulaBar = False
        .DisplayStatusBar = False
        .CommandBars("Full Screen").Visible = True
        .CommandBars("Worksheet Menu Bar").Enabled = False
        .CommandBars("Standard").Visible = False
        .CommandBars("Formatting").Visible = False
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("C7:C11,C13,C16,C19,C22,E7,E10,E13,E16,G13,G16")) Is Nothing Then
        Target.Copy
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tabArray As Variant
    Dim i As Long
    tabArray = Array("C7", "C8", "C9", "C10", "C11", "C16", "C19", "C22", "E7", "E10", "E13", "E16", "G13", "G16")
    Application.ScreenUpdating = False
    For i = LBound(tabArray) To UBound(tabArray)
        If tabArray(i) = Target.Address(0, 0) Then
            If i = UBound(tabArray) Then
                Me.Range(tabArray(LBound(tabArray))).Select
            Else
                Me.Range(tabArray(i + 1)).Select
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Sub PasteasValue()
Selection.PasteSpecial Paste:=xlPasteValues
End Sub
 
Upvote 0
New module called Clipboard for buttons:
VBA Code: 
Sub ClipboardStop_Click()

End Sub

Sub ClipboardStart_Click()

End Sub

Sub ClipboardReset_Click()

End Sub
 
Upvote 0
So I've done a bit of work to the design and code. I have attached an example of the worksheet.

The tab order isn't consistently kept to and this also seems to impact on what is being held in the clipboard. The correct order when tabbing through cells should be:

"C7", "C8", "C9", "C10", "C11", "C13", "C16", "C19", "E7", "E10", "E13", "G13", "I13", "E16", "G16", "I16", "E19", "C22"

I'm also unsure how I would go about stopping the VBA from copying a cell if it detects that it is empty.

Lastly, I really need a way to stop the worksheet from automatically copying when the pause button is pressed and resume when the play button is pressed. Finally, I'd like to see what VBA can check for cells and clear cells with data in them when the last red button is pressed (with scope for making a list of cell exceptions within the VBA).

Thank you very much for your help.

drive.google.com

Export.xlsm

drive.google.com drive.google.com
 
Upvote 0
Code

ThisWorksheet:

VBA Code: 
Option Explicit

Private WithEvents oCbarEvents As CommandBars

#If VBA7 Then
    Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long
#Else
    Private Declare Function GetClipboardSequenceNumber Lib "user32" () As Long
#End If

Private Const TARGET_SHEET As String = "Clipboard"
Private Const TARGET_RANGE As String = "C7:C11,C13,C16,C19,C22,E7,E10,E13,E16,E19,G13,G16,I16"
Private Const TARGET_INFO_RANGE As String = "C4"

Private Sub Workbook_Open()
    Set oCbarEvents = Application.CommandBars
Application.EnableEvents = False
    Dim Sh As Worksheet
    For Each Sh In Worksheets
        If Sh.Name = "Property Numbering" Then
            Sh.Protect UserInterFaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
            Sh.Range("C14,C8").ClearContents
            Sh.Range("B2").Value = "'Property Reference Guide (Click Arrow to Start)"
            Sh.Range("C14,C8").Value = "'Choose"
        ElseIf Sh.Name = "VO Areas" Then
            Sh.Protect UserInterFaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
            Sh.Range("C4").ClearContents
            Sh.Range("C4").Value = "'Choose"
        Else
            Sh.Protect UserInterFaceOnly:=True
        End If
    Next
Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Set oCbarEvents = Application.CommandBars
End Sub

Private Sub oCbarEvents_OnUpdate()

    Static lPrevSN As Long
   
    Dim MyDataObject As Object
    Dim lCutCopy As Long
    Dim sClipText As String
   
    If GetClipboardSequenceNumber <> lPrevSN Then
        If Application.CutCopyMode <> False Then
            With Sheets(TARGET_SHEET)
                lCutCopy = Application.CutCopyMode
                If Not Intersect(ActiveWindow.RangeSelection, .Range(TARGET_RANGE)) Is Nothing Then
                    Set MyDataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                    MyDataObject.GetFromClipboard
                    sClipText = MyDataObject.GetText(1)
                    Mid(sClipText, Len(sClipText), 1) = vbNullChar
                    If InStr(sClipText, Chr(&HA)) Then
                        sClipText = Replace(sClipText, Chr(&H22), "")
                    End If
                    If .ProtectContents Then
                     .Unprotect
                    .Range(TARGET_INFO_RANGE) = sClipText
                    .Protect
                   End If
                    Set oCbarEvents = Nothing
                    If lCutCopy = 1 Then
                        ActiveWindow.RangeSelection.Copy
                    Else
                        ActiveWindow.RangeSelection.Cut
                    End If
                    Set oCbarEvents = Application.CommandBars
                End If
            End With
        End If
    End If
    lPrevSN = GetClipboardSequenceNumber
End Sub

Clipboard Worksheet:
VBA Code: 
Option Explicit

Private Sub Worksheet_Activate()
    With Worksheets("Clipboard")
'    MsgBox "Software relies heavily on the Windows clipboard." & Chr(13) & Chr(13) & "If you need to duplicate information to multiple accounts/properties, use this tool." & Chr(13) & Chr(13) & "Type the information needed, press ""Enter"" and then any cell you click on will automatically be copied to the clipboard.", vbInformation + vbOKOnly, "Automatic Clipboard"
         .Range("C4").Select
    End With
    With ActiveWindow
        .DisplayFormulas = False
        .DisplayHeadings = False
        .DisplayGridlines = False
        .DisplayHorizontalScrollBar = False
        .DisplayVerticalScrollBar = False
    End With
    With Application
        .DisplayFullScreen = True
        .DisplayFormulaBar = False
        .DisplayStatusBar = False
        .CommandBars("Full Screen").Visible = True
        .CommandBars("Worksheet Menu Bar").Enabled = False
        .CommandBars("Standard").Visible = False
        .CommandBars("Formatting").Visible = False
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("C7:C11,C13,C16,C19,C22,E7,E10,E13,E16,E19,G13,G16,I16")) Is Nothing Then
        Target.Copy
    End If
        Dim Order
        Static Last
        Dim i As Integer
            Order = Array("C7", "C8", "C9", "C10", "C11", "C13", "C16", "C19", "E7", "E10", "E13", "G13", "I13", "E16", "G16", "I16", "E19", "C22")
            For i = 0 To UBound(Order)
                If StrComp(Order(i), Target.Address(0, 0), vbTextCompare) = 0 Then
                Last = Order(i)
                Exit Sub
                End If
            Next
            For i = 0 To UBound(Order)
                If StrComp(Order(i), Last, vbTextCompare) = 0 Then
                i = (i + 1) Mod UBound(Order)
                Last = Order(i)
            Exit For
    End If
            Next
            If i > UBound(Order) Then Last = Order(0)
            Application.EnableEvents = False
            Range(Last).Select
            Application.EnableEvents = True
End Sub

Sub PasteasValue()
Selection.PasteSpecial Paste:=xlPasteValues
End Sub
 
Upvote 0
I also need the focus to change if the user clicks on a different cell, so when tab is next pressed, it goes to the next cell in the list after the one selected rather than what happens at the moment, which is despite a different cell being selected, the focus goes back to whichever cell is next according to the original list.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Using VBA code in a protected excel sheet
Replies
2
Views
547
MagicCarpet
M
T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
351
tixarah
T
C
  • Question Question
Move Completed cells auto using VBA when they have been changed to completed
Replies
5
Views
423
dmt32
D
J
  • Question Question
A VBA Code to Transfer rows of cells across Sheets based on Certain Column Value
Replies
2
Views
263
Peter_SSs
Peter_SSs
D
  • Solved
Excel VBA for Changing Tab Name & Return Blank Cell to Formula
Replies
5
Views
440
DjTRex2002
D

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top