Setting tab order, adding ability to stop/start code and refine functionality

[MSXL]

I'm working on a concept to create an automatic clipboard, working from one sheet only.

First feature needed is to be able to set the tab order C7,C8,C9,C10,C11,C13,C16,C19,E7,E10,E13,G13,I13,E16,G16,I16,E19,C22 permanently regardless of whether any data is input into the existing cell. It should be possible to also click on a cell and when tab is pressed, it goes on to the next cell in this list following the selected cell. So for example, the user selects C13 and presses tab. It should then move on to C16.

Once the user is ready, code should start enabling a user to select any cell and automatically copy the contents to the clipboard. The user should be able to pause the code at any point to be able to paste data from elsewhere into the worksheet or type new data. I've added control buttons with the intention of those controlling start/stop.

At the moment, I have it working in part and have attached a copy so you can see what I am working with.

You will see that currently using tab messes up what is copied to the clipboard, clicking on a cell doesn't work as expected and for reasons I cannot fathom, it does not ever tab through to C22.

https://drive.google.com/file/d/1PobGUO5avY3zxcz1llPd9UnI6-dMSIrI/view?usp=sharing

Thank you for your help.

[arnelgp]

what i worked on was the Tab/ Shift-Tab.
you need to add code for the Clipboard thing.

[MSXL]

Thank you for your reply. I tried testing the attached and when I pressed tab, it immediately came up with an error:

Tun-time error '13':
Type mismatch

For i = 0 To UBound(arr)

[arnelgp]

obviously the code in Thisworkbook Open did not fire-up.
close the workbook first.
upon opening, if you see any Macro Warning, (yellow band) just enable it.

[arnelgp]

here i select $C$7 first on Clipboard sheet.
then, you can Tab/Shift tab.

[MSXL]

Thank you, that's awesome. You even considered back tabbing, which I hadn't.

I'm not sure how to re-introduce the automatic copy functionality, as trying to reinsert the code where it was or even reducing it to "Target.Copy" after module1 brings up an error within module1

Clipboard code:

If Not Intersect(Target, Range("C7,C8,C9,C10,C11,C13,C16,C19,E7,E10,E13,G13,I13,E16,G16,I16,E19,C22")) Is Nothing Then Target.Copy
End If


Error line with mismatch:

strAddress = arr(0)

[MSXL]

Rethinking it, this is what I have come up with:


Option Explicit

Public arr As Variant
Public strAddress As String


Public Sub ProcessTab()
Dim i As Integer
If Len(strAddress) <> 0 Then
For i = 0 To UBound(arr)
If arr(i) = Split(strAddress, ":")(0) Then
If i = UBound(arr) Then
i = 0
Else
i = i + 1
End If
Exit For
End If
Next
ActiveSheet.Range(arr(i)).Select
ActiveSheet.Range.Copy
Else
strAddress = arr(0)
End If
End Sub




Public Sub ProcessBkTab()
Dim i As Integer
If Len(strAddress) <> 0 Then
For i = 0 To UBound(arr)
If arr(i) = Split(strAddress, ":")(0) Then
If i = 0 Then
i = UBound(arr)
Else
i = i - 1
End If
Exit For
End If
Next
ActiveSheet.Range(arr(i)).Select
ActiveSheet.Range.Copy
Else
strAddress = arr(0)
End If
End Sub


I think it might be best to change ActiveSheet to the worksheet name so it doesn't throw an error if the user switches between workbooks.

It's coming back up with the same mismatch error when trying to select different cells or tabbing now.

https://drive.google.com/file/d/1BuTw372Xg48bGZ6Dlk0VAhPAqTpPtWq2/view?usp=sharing

[MSXL]

Changing to the worksheet name doesn't work:


Option Explicit

Public arr As Variant
Public strAddress As String


Public Sub ProcessTab()
Dim i As Integer
If Len(strAddress) <> 0 Then
For i = 0 To UBound(arr)
If arr(i) = Split(strAddress, ":")(0) Then
If i = UBound(arr) Then
i = 0
Else
i = i + 1
End If
Exit For
End If
Next
Worksheets("Clipboard").Range(arr(i)).Select
Worksheets("Clipboard").Range(arr(i)).Copy
Else
strAddress = arr(0)
End If
End Sub




Public Sub ProcessBkTab()
Dim i As Integer
If Len(strAddress) <> 0 Then
For i = 0 To UBound(arr)
If arr(i) = Split(strAddress, ":")(0) Then
If i = 0 Then
i = UBound(arr)
Else
i = i - 1
End If
Exit For
End If
Next
Worksheets("Clipboard").Range(arr(i)).Select
Worksheets("Clipboard").Range(arr(i)).Copy
Else
strAddress = arr(0)
End If
End Sub

[MSXL]

Seems to work until try clicking a cell, the focus doesn't change to that cell and the clipboard remains on the last selection made by tabbing.

[MSXL]

Modifying the VBA on the worksheet Clipboard seems to fix this.


Private Sub Worksheet_SelectionChange(ByVal Target As Range) Module1.strAddress = Target.Address
Target.Copy
End Sub

Now need to figure out how to disable automatic copying using the buttons to allow user to paste data from an external source or type it in and tab without copying.

Also, trying to avoid empty cells from being copied when automatic copying is enabled.

[MSXL]

Thought this might be a partial solution but it didn't make any difference:


Private Sub Worksheet_SelectionChange(ByVal Target As Range) Module1.strAddress = Target.Address
If Not IsEmpty(Target.Address) Then
Target.Copy
End If
End Sub

[arnelgp]

why do you need to have the Clipboard involve, when you can Reference any cell and check if it has value.
then you assign the value to an array/variable.

when it is time to "paste" just read out from the variables.

EDIT:

what does the "play", "pause", "refresh" buttons need to do?
maybe i can help you out, without the Clipboard thing.

[MSXL]

Thought it might be something to do with needing to introduce similar in the module but unsure how to phrase what should be inserted in brackets. I tried a few things and none of them worked including "Range(arr(i))"


Option Explicit

Public arr As Variant
Public strAddress As String


Public Sub ProcessTab()
Dim i As Integer
If Len(strAddress) <> 0 Then
For i = 0 To UBound(arr)
If arr(i) = Split(strAddress, ":")(0) Then
If i = UBound(arr) Then
i = 0
Else
i = i + 1
End If
Exit For
End If
Next
Worksheets("Clipboard").Range(arr(i)).Select
If Not IsEmpty() = True Then
Worksheets("Clipboard").Range(arr(i)).Copy
End If
Else
strAddress = arr(0)
End If
End Sub




Public Sub ProcessBkTab()
Dim i As Integer
If Len(strAddress) <> 0 Then
For i = 0 To UBound(arr)
If arr(i) = Split(strAddress, ":")(0) Then
If i = 0 Then
i = UBound(arr)
Else
i = i - 1
End If
Exit For
End If
Next
Worksheets("Clipboard").Range(arr(i)).Select
If Not IsEmpty() = True Then
Worksheets("Clipboard").Range(arr(i)).Copy
End If
Else
strAddress = arr(0)
End If
End Sub

[MSXL]

Thanks for your reply. The play button is for VBA to loop continuously providing the clipboard automatically copying functionality, the pause button is to allow users to type or "paste special-value" text into the cells without the VBA loop interrupting. The refresh button is to clear all the cells of values.

[MSXL]

It might be worth me explaining that the main and original idea was to be able to click any cell that contains data and have it automatically copy to the clipboard, so that it can be pasted quickly to another application.

[arnelgp]

here check and test again those 3 buttons.

[MSXL]

w00t! I've played with it a little bit and it seems to work exactly as I had imagined. I have no idea how you did that! Thank you. I will let you know if I come across any issues.

[MSXL]

Is there a way to insert the words "Input Mode" in the space between the pause and undo buttons when the worksheet first opens or pause is pressed and "Copy Mode" when the play button is pressed (centred in I3).

[arnelgp]

here i added "Status" rectangle shape.

[MSXL]

In the mean time, I have added the following to Clipboard VBA


Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Cancel = True
MsgBox ("To paste data, press ""Ctrl"" & ""V""."), _
vbInformation, "Automatic Clipboard"
End Sub


Sub PasteasValue()
Selection.PasteSpecial Paste:=xlPasteValues

Within Module1, I'd like to add a prompt "Are you sure you want to clear all the data? Yes/No.

If yes, clear. If no, cancel.

I figure that would go in here.


Public Sub ClipClear()
Call ClipOff
Sheet10.Range("$C$4") = Null
End Sub


vbYesNo with default button No vbDefaultButton2.

[MSXL]

That's brilliant, thank you. Is it possible to alternate the text colour? Green for Input and Red for Copy Mode.

[MSXL]

This brings up the prompt but cancel doesn't stop the procedure.


Public Sub ClipClear()
Call ClipOff
MsgBox "Are you sure you wish to clear the data?", vbQuestion + vbYesNo + vbDefaultButton2, "Automatic Clipboard"
Sheet10.Range("$C$4") = Null
End Sub

[MSXL]

Okay, this is the solution.


Public Sub ClipClear()Dim Answer As Integer
Answer = MsgBox("Are you sure you wish to clear the data?", vbQuestion + vbYesNo + vbDefaultButton2, "Automatic Clipboard")
If Answer = vbYes Then
Call ClipOff
' MsgBox "Cleared"
Sheet10.Range("C7,C8,C9,C10,C11,C13,C16,C19,E13,G13,I13,E16,G16,I16").ClearContents
Sheet10.Range("E7:I7").ClearContents
Sheet10.Range("E10:I10").ClearContents
Sheet10.Range("E19:I19").ClearContents
Sheet10.Range("C22:I22").ClearContents
Sheet10.Range("$C$4") = Null
Else
'Do nothing
End If
End Sub

I'd still like the message to show as green or red as described previously.

[MSXL]

I think I have figured it out, is this how you would do it?


Public Sub ClipOn()
Dim thisAddress As String
thisAddress = Split(strAddress, ":")(0)
With Sheet10
.IsClipRunning = True
' unprotect and change the color of the "play" button to red (or you may use any color)
.Unprotect
.Shapes("Status").TextFrame.Characters.Text = "Copy Mode"
.Shapes("Status").TextFrame.Characters.Font.Color = vbRed
.Shapes("Button 33").TextFrame.Characters.Font.Color = vbRed
.Protect
If Len(Trim$(.Range(thisAddress).value & "")) Then
Call putToClipboard(.Range(thisAddress).value)
End If
End With
End Sub

Public Sub ClipOff()
With Sheet10
' unprotect to re-instate the color of "play" button to black
.Unprotect
.Shapes("Status").TextFrame.Characters.Text = "Input Mode"
.Shapes("Status").TextFrame.Characters.Font.Color = RGB(146, 208, 80)
.Shapes("Button 33").TextFrame.Characters.Font.Color = vbBlack
.IsClipRunning = False
.Protect
End With
End Sub

[MSXL]

I'm trying to change the background colour but cannot get the syntax correct.


.Shapes("Status").TextFrame.Fill.BackColor.RGB = RGB(146, 208, 80)

How do I define the background colour of this textframe please?

[arnelgp]

here again your workbook.

[MSXL]

Thank you very much, you have been so helpful.

[snb]

Identical functionality:


Buttons(2).Font.Color = 255
Shapes("Button 33").TextFrame.Characters.Font.Color = vbRed

[MSXL]

Thanks snb.

@arnelgp

Ah, some functionality is missing and I had assumed it was there before. The idea behind this worksheet is that pressing play not only displays the last cell selected containing data, it also automatically copies it to the Windows clipboard.

Is that an easy feature to add now that we have start/stop functionality? If so, what additional code is required/where please?

[MSXL]

Is this the best way?

Modify the putToClipboard code:

Public Function putToClipboard(ByVal theValue As Variant)
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText theValue
Sheet10.Range("$C$4") = theValue
End With
Sheet10.Range("$C$4").Copy
End Function

[arnelgp]

forgot to PutInClipboard:


Public Function putToClipboard(ByVal theValue As Variant)
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText theValue & ""
.PutInClipboard
End With
Sheet10.Range("$C$4") = theValue
End Function

[MSXL]

Thank you so much.


forgot to PutInClipboard:


Public Function putToClipboard(ByVal theValue As Variant)
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText theValue & ""
.PutInClipboard
End With
Sheet10.Range("$C$4") = theValue
End Function

[MSXL]

I have just tried using another workbook open at the same time and it's producing errors:

http://www.vbaexpress.com/forum/image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAVAAAADgCAYAAABVVT4YAAAWoklEQVR4nO3dTYgb 6Z3H8V8ZQ5Yl2U1CLiGH9oCUxmYaDO1LlyHGGRiQ7EPjgw5z8BgfJPawuDRgyMAYu7HBgYaRTA5 L62A8PgxsH0wf2hIEJoMXRn3pBoPNGI80uBs25BLYBJZlYUNqD3rpklQlVT16qSr7 wHhRKpSPU 9/Or/PCV7LMdxXAEAIjspSZVKJe52AECqlMtlnYi7EQCQVgQoABgiQAHA0Invvv/3uNsAAKl04kc/iLsJAJBODOEBwNCJH/3gZ3G3AQBS6cQPf/DPcbcBAFLphP7pXNxtAIBUYg4UAAwRoABgiAAF8NawLEsHBwcTlzs4OJBlWVNvL1KANkqWLOu8H rQDl1DJsmSVGkPrlNQIWiUB2g/Oy7LCt7NRGuxj0GeL6nujZOl88EHx9O/4NW75qNuepo9R973BFvTgvCXr/APNpsf ho/BvI99Gq6rOOzv7 vcuXNjQ/Tg4EDnzp3T/v7 9Bt0HMcNq16UK8m1qy3fz1tV27Vt21WxHvo7Y9equrZsd6BL9aIru r697L7uYruaC/rblFyF939ejH4mLhu57gMHJNW1bVjaOcIv30/j23Y9ty3M kYTPnl489HDNjf33clufv7 5E i8pxHDfyEN62bTWdTZ87X1tPt5vTJ3os3tcvMxEWz62rqJp2hndCY0c1FbWem2Xb5iBzQ58Vpdp IB IQcd9H1Nh0pMIX qzYlLOZhP5i3lZXV30rUW/lubq6OpNtRZ8DLXymqu0XHptyVNVnhaG3fYaXw0PKzoi3M9QqNbrTAJ7hycgQdHj43Ch5Ph cYhi3bvvBeVlZR03VlO9 1ihZsvI1qeko67ctSVJO6z4B1NipScV19fJzpO 7WyoNDwt0n6g897hWfuBznv7MKPhqH0mO7TNMdsI2Mfhj69Glxna90HrDx6D4PNkVEM7NVuFSxn lblZl13ZGlu21f2CbQ30Ps8zIlqPslzH7Puh8DPP9/vutO6Xhc62Mu47SZjhE5xGektFDpKwuFWzV7g2dZDs12YVLygau19F cF5Z533VXVeu68ptVXXG8/nLezs603LlulvK S3vtlR9mT8 OdoPdD7/UtVW9/N6IXhbQ tmbnwjt1WVrWJnma2ccluu3HpRsqtqdd/zk skqOeCbOu7l1IxqPwc085J2k /VaHl6YMcZQPmYENplJSvFfXZjePSb w2IrR90vHt8dv3vusPH u4fPEv587qtkFXcpIylxSwe/GL6npZPWxvhi7f8MsM864/TJu34c9H8Put1r Y mLzjL1YlPOx93reIrzM6m8ITqP8JQUfQ60M89Td4veOaVW1bW7c4LD822Dc0Pj5ghbbtUenkca2 k5/0ePtDfzvwdZOXjdo/VBzTsH74PhrPP2J0s7AZf3bF2oOVBp4TZz/9G5jTHvCH1/fhg19b5hj5neeBHVhcLmRueDuMiNz9kNzs2GX8W5rqv0yfP75nI j32 w30JdR nWm/PUjOY9vYzmQDtyWi82tf20U4O2n26r6Rm6BgoxR/i d0KssaOa3xxZ5pd6Xy/1XVv9yiI/PFQMs 5UIu6DoHaGNDA8y9eif0Gx3q1MOtXJmXuj0xOB2wjb9mnngCMcs/cnTZy2H hed/je/5pLBdm1eyND04GpjP72oi8TKMR mer4TrXfJlxHKeYdtod5Om/C HeguZtVydlUQ2093ZaqN N6cpLRjW86Q6KX cX tCO3XlRz 6na3QdogcP3qdrZmevLbhc6Qzi3O6SbSkY3vqh6wmTSNuLbx6baT7fVVFNO1jMnmHXU1PFNLxnm cXxNpO8YjzM85xn0YGla5j k780plTblqDvPNEn2jOwo1V/Q8u3v9HL4jpu5oW/clqp2TfcetKOtayq3rmJzW08bT7XdDFl5DbfTT tb9X/P0P5OL1VU/ZsbyvTfejl92yX1n4CH3caktkc9vmHXj3zMOjc0u9ryVN2dV6tqd296x5rftgZX96nowiwTuV/SbI7vLM/1MOdnwgU9MJpHiE7xN5EyuvFZUbVa5 FRqGOUudH5OUl28Anzg6Bbnd/yauvBx45UvdkZLjdKI0OO93 ZCbfuOM1v1Zq0THcY7 SdyVMYQe1UVmds709sGiqNDOE8F0f7gT52pv25WGc/DLZ5zDYC2z4k6vENs36UY9Zf5am2m4PD9/4mLhVkNx0N/KKplvf0r7P/7eHthVkmSr8G9kuI4zvufJzFfgt7jBNu0tP2WYfodH VM7euogaf5k5cZctVvdj96Yplycpua9yj 9yWq1b15fHyVlbbhZa 6W0ze6Y75Dj rPegcuK6gRu9qao9 vMa/13QGW6NH76Pa2dGN76pq1jLdz/b0XqrKru3XuaGvqjqeCj6sfSFyRCv//2d7Tvv14 f6E7axph9PLI/Ih5fv/WNjplHY9NR0w4YFWUuqWAP/gTNrtY7c8KWJcvKq1asj2wvzDKT uW7X8Ic3xDn49T7LcIxTrIwT9u9IToty3Ecl/8uPN5VjZKle2fGB02YZfDu4b8LDwBTIEABwNDJuBsAxCm35U58yBJmGbybqEABwBABCgCGCFAAM ESAAoAhAhQADBGgAGCIAAUAQwQoABgiQAHAEAEKAIYIUAAwRIACgCECFAAMEaAAYIgABQBDBCgA GCJAAcAQAQoAhghQADBEgAKAIQIUAAwRoABgiAAFAEMEKAAYIkABwBABCgCGCFAAMESAAoAhAhQ ADBGgAGCIAAUAQwQoABgiQAHAEAEKAIYIUAAwRIACgCECFAAMEaAAYIgABQBDBCgAGCJAAcAQAQ oAhtIfoH981HkBwIKdjLsBU/t o/PnL67F2w4A75x0V6B/fCT932HnRRUKYMHSHaDfb8j9ieT RMeVKAAsSHoDtFt9/v2n0t9/KqpQAAuX3gDtVp860XnFXYW2q7Ysyzp 2VW142hIoyTLslVtS1JDJaukRhztAN4B6QxQT/XZE18V2lDJspTdLqjlunJ7r1uvtBlHcuW25LpNOZkYtg28Y9IZoN7qsyemKrRRyqtWrMttOhrIr NyWtnILbQqABUtfgPpUnz0Lr0LbVd2tralyc1JStlW1g4b3bVVtW9VGVXbv81JDvcq2s453GN4b lns/7w3ZvZ/78a5jqTS2Qg5adri9JTV834va75Ia7arsgb4AyZa APWrPnsWXYW2XmlvraDLY4fLbVXtrMor9f7wvlXYVnYgTPZUvis9dl25bl3FWl6WdVenW93lKy UH0i7mvLWjtZ70wX1FZWzk Y626raeb2otLrtqEv5oLCatKy3vVvK b4Xtd 97wHSI10BOqb67EncE/n2rrb3iqp7xvMZ57Eq2tZuP0nWVHncmwLI6WZlTWuVx/15zMzlgtZevPYEz5oqLU/g5G6qslbTzrgEbWyqrIoe9ydHc1ov7ml71ydBQyxbvDU0ZTH8Xqh D62TcdRk/hYpkq4AHVd99iyyCs2e1treK7XGLdN6pb2108rOdMMrWh4ImYyWV6QXryeMfffKynqG5fma6bJr Oj3SoaH3QvXb73uA9EhPgIaoPnsWVoVmLquwVtPdSZN2k0I2shcazMq2Xr QVpYnlG5rlcFfCriumkHlXpRlg8y830CypCdAw1SfPQurQjNyHlekcrb74MejUeo8eOkOr71zmO 3qVZVXbk0xVN1TeXPo 1TR2GdZuXUV98q6GuYJTZRlA7/DoN88RELKpCNAI1SfPYurQh013ZYqL/KDP6TfWe/ jCkjp9l7MNT5LLtdUGuq3zgVVV/fOf6 8orqwz jGpHTllvXSjnraWfQg6coywaZR7 BZLEcx3ErlUrc7RjvP96T 8ND/f1nox dXOr8 bej0c9O/Fmy/vuU9Ks3823fQjVUsna0zlNrIFblcjkFFahB9dmTuCfyAN4qyQ/QKHOfwxLwd QBvL2SHaBTVJ89b18VmtMWw3cgEZIdoNNUnz1UoQDmJLkBOoPqs ftq0IBJEFyA3QW1WcPVSiAOUhmgM6w uyhCgUwa8kM0FlWnz1UoQBmLHkBOofqs4cqFMAsJS9A51F99lCFApihZAXoHKvPHqpQALOSrACd Z/XZQxUKYEaSE6ALqD57qEIBzEJyAnQR1WcPVSiAGUhGgE5Rff7tyP fspuEKhTAtJIRoIusPnuoQgFMKf4AnXLu8 TS8T qHBVVKIBpxB gcVSfPVShAKYQb4DO4Mm76RxoD1UoAFPxBmic1WcPVSgAQ/FF1wJ/9zkJVSgAE/EFaBKqzx6qUAAGTsay1T8 kv73UO7PJOt/YmnBCPcfJOvP3Sr0F9fibg6AFIgnQLuV3on/jGXr432/QYACCCWeAP3Vm1g2CwCzlIQZSABIJQIUAAwRoFNqV21Zpcact9JQySqpIUmNkizLVrUd2CDZdlV BH8/FQJs8bY3DpP0z QtUsixZvVfofRlPvxslT1u7L9u886aNmHKfpxcBmja5LbluU05mDt/dKI3eDPzem3ebwmxzLm1pqGTl9aLSkuu6cl1XrcIr7SY8GNY87XVdV825nBwew8dnnudkwsXzEA lIovZrvVBRtzxJkHG25MTYJCQbFehMtVW1bVXb3mHg8bCuURodXrWr9vEwsVHyDMWChkTDQ8XBI Wdpd0ITA7bRrtqy8jWplu98T8P/vX4fG1XZ/f75DV 97fL2xWdZT0Xjv02ffgYWqN7vH388RmSWtaKa7vru PHtntxvP21V7aDpAr/9HMWk9obZN0Pts0qq h6f4W2F6FfYY5JwBOjM7amc3dF6dzhVL9aU7560ufWi9sqbAyfa7vaeirccZSQ1Xp9WqzcUq6 ofHXS/FtbVXtwyLn qqy9MWsEbSPjNOXWi1KxLtd1tZXzf6/fx7vSY9eV624pN7KVmvLW8T5w6ysqZ8NdJP7bHO5nXcqHnXMLPh6jctpqVaRy1vCijtLvtqp2Vu WVume6YFvZgbCZtJ nNW7f LSvclrLgedExH6FPibJRoDO3JoqreOTPXezorUXrzsnT 6mKms17fTP0V1tq6Kb3YVzTidIO/9nXcW9V2qN21R7V9t7g0PO3M2K1sasEnkbAXqh729wH4z0O6rGpsqq6HG/nzmtF/e0HWpycszx8JNx1Oxd1JEfyETod/fY1T0JlHEeq6LtgTnX8fu5Y6 cDTFymdzegX3T2FR5pH3O5BAP1a IxyTBCNCFyuhyYU217hXV2CxLhcvHF0i7N1yzZFl51SZ9XeuV9tZOKxulCVG34WtNp8dudEXLA1 d9Rssr0ovXU1wie2VlPUP4vFnDQ8ttuXK71Wj44ihCv0Mdu0n7ubvUwEOkGT7MiXpuSWbnZIoRo AuWuVzQWm1HDTW0U/NUj42SrOwr3epfCHUVw3zhcAXZehU8hDfdRmQvNJgZbb1 Ia0sT3Flr1WOpx4W9bQ5c1mFtSjBH7HfhtV/4r2t/fJBgC5axtGtYk07pR3ViuuDQyLPnbtdvTu5Osytqzjw0KOt6t0Ja0XdhpE9lTc9M73Vqyr3pyqy Or0Wsc25dRX3yro67x8atqsqebfR3tX23poKlzMK1 5x/R7SHd575/7a1asqr9yaUQVpsJ8H2je6z9vV6uR54bn3K1kI0Bjk1ouq1V6o4r2ycjdV0fEw9aoKIapD70MPS 5Z1Vbo1Zg500jZy6yoOP/32e2 iourrO/3hdra8onqzN5eXkfN4qM2FoZ6ObDOnLbeulYG5vjk8uc0se9plycqWtVLvDYlDtHtsv0c2JqdZ7/fTsixltwtqjT6VMe1MiPaOM7rPs9vq3HzHnhPz7leyWI7juJVKJe52AECqlMtlKlAAMEWAAoAhA hQADBGgAGCIAAUAQwQoABgiQAHAEAEKAIYIUAAwRIACgCECFAAMEaAAYIgABQBDBCgAGCJAAcAQ AQoAhghQADBEgAKAIQIUAAwRoABgiAAFAEMEKAAYIkABwBABCgCGCFAAMESAAoAhAhQADBGgAGC IAAUAQwQoABgiQAHAEAEKAIYIUAAwRIACgCECFAAMEaAAYOikJP31r3 Nux0AkDpUoABgiAAFAEMEKAAYIkABwBABCgCGCFAAMESAAoAhAhQADBGgAGCIAAUAQwQoABgiQA HAEAEKAIYIUAAwRIACgKGTcTcA4/34t3 KuwmQ9Jff/DzS8l999dWcWoIoPvjgg7l PwEKzMm5c fibsI7bX9/f 7bIEBT4uhf/lFnz57V8 fP XOBf/5XqRn3oUeCWY7juHfu3Im7HQjQG8L/ZMvW8 fPY27Nu2fp3/5HktkQngo0Xvv7 3Mdwt 5c4eHSGlBeC7e2bNn424CEo4ATQku5sXjpoVJCNCU4GJePG5amIQATQku5sXjpoVJCNCU4GJePG 5amIQATQku5sXjpoVJCNCU4GJePG5amIQATYlkX8yHenhlSUtLnteVhzocWurrT5d05aHn3cOHu rI09F6CvE03rZF933X48IqWPv06zDfo06VPFWbJdwkBmhKJvZgPH rK0gVtLD/S0dFR//Xs8q4uLF1RcDZ rU8vbGj50ZGeXD 1yBaHluybFpKAAE2JZF7Mh3r4yYZ0 5mO7l8c OTU9Sd6dlva GS0Eu1UrNf0 vYzDa2WKIm9aSExCNCUSOTFfPgH7R6s6vKv/SvIU9f/VR8d7OoPQwl6 PATbSw/Smzl2ZPMm9a8fa1PPVMx/qP73nDeu y40cbbiwBNiURezG9aOli9rID8lPSesqsHar3xvLX7iS7sXtazJJeeXYm8aU3hYOPC4Dz10pIub Bx4ljgeGXSmYh5J14KC8UtdW/q9PuxN2zxa1saFd2 OlABNibflYj6QtOpTlSZRIm9aU1jtB6Nnrvr26vECX29pQ7f1eX9kcFEffnSgXd Dtarbz 6rfxu8WNLt1S/1 3csQQnQlEjkxfxeVqsHLb0JXOCNWgeryr53/M7q5c/1JCXVytty04rkYEMXPBXqtS DFlzWewMjj1N6b1l6/SYFd8YZIkBTIpEX86lf6/Lql/pdwOTX4cPf6Uu/If7F 3r00Ze65vNTpyRJ5E1r3lZv69lQleo/V/1ag1l5qDevpeX3kj2vPWsEaEok82I peuf35Y2Loz8xvDw4RVd2JBuf35dfpfUxfvPdFsbuhDqN4jxSORNa54ufqiPDjb0SainQQfa2Do docPP9GGbquU/KntmeJfpE JxF7Mp67rydGv9fDKBS1teN5fva1nR/7h2V1R1588UmvpmpZe39azJ OWjcfZs2eld pfpL o 0eP9OmS91h pEdHnrlOed7/8PdaWrrmWS55x3DeCNCU6P1nJpLplK4/OdL1CUtdvH80dCFe1P2jI92fX8Om8vz58/6/SJ92o/u 49T1JzoaXDLgmFzU/aOhb7h4X0dHST16i8EQPiWSG55vr2ROmyBJCNCU4GJePG5amIQATQku5sXjphXkou77zou ewjQlOBiXjxuWpiEAE0JLubF46aFSQjQlOBiXjxuWpiEAE2J58 f90OUPxf7JxDEchzHvXPnTtztQIAf//ZPcTcBkv7ym59HWv6rr77SuXPn5tQahLG/v68PPvhgbt9/584dfkgPzMv /n7cTcCcEaAJF7XyQTLMs/JBcjAHCgCGCFAAMESAAoAhAhQADBGgAGCIAAUAQwQoABgiQAHAEAEKAIYIUAAwRIACgCECFAAME aAAYIgABQBDluM4btyNAIA0 n 7k7dOr7baDQAAAABJRU5ErkJggg==


Private WithEvents oCbarEvents As CommandBars

How can this be resolved?

[MSXL]

Ah, the error message image didn't attach.

30122

[MSXL]

It appears to be something to do with any worksheet containing "Private Sub Worksheet_Change(ByVal Target As Range)" as that's when the error occurs, when switching between sheets in another open workbook.

For example:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("C4"), Target) Is Nothing Then
If Range("C4").Value = "" Then
Application.EnableEvents = False
Range("C4").Value = "'Choose"
Application.EnableEvents = True
End If
End If
End Sub


My workbooks contain a lot of these types of events so I need to know how to avoid this error and have everything continue to work normally.

[snb]

Private Sub Worksheet_Change(ByVal Target As Range)
If target.address & target ="$C$4" Then
Application.EnableEvents = False
target = "Choose"
Application.EnableEvents = True
End If
End Sub

You'd better use a Userform.

[MSXL]

Private Sub Worksheet_Change(ByVal Target As Range)
If target.address & target ="$C$4" Then
Application.EnableEvents = False
target = "Choose"
Application.EnableEvents = True
End If
End Sub

You'd better use a Userform.

Surely there must be another way that doesn't require building from the ground up, when this is so close? I wouldn't know where to start and I don't know whether the functionality of this clipboard would work inside a userform.

[Aussiebear]

This is rapidly becoming a rather complex issue. Normally a thread composes a singular question. Msxl from here on in, single questions only otherwise start a new thread.

[MSXL]

Okay, let's try again. I'm occasionally getting an error with the following:


Option Explicit

Public arr As Variant
Public strAddress As String


Public Sub ProcessTab()
Dim i As Integer
If Len(strAddress) <> 0 Then
For i = 0 To UBound(arr)
If arr(i) = Split(strAddress, ":")(0) Then
If i = UBound(arr) Then
i = 0
Else
i = i + 1
End If
Exit For
End If
Next
ActiveSheet.Range(arr(i)).Select
Else
strAddress = arr(0)
End If
End Sub


Public Sub ProcessBkTab()
Dim i As Integer
If Len(strAddress) <> 0 Then
For i = 0 To UBound(arr)
If arr(i) = Split(strAddress, ":")(0) Then
If i = 0 Then
i = UBound(arr)
Else
i = i - 1
End If
Exit For
End If
Next
ActiveSheet.Range(arr(i)).Select
Else
strAddress = arr(0)
End If
End Sub

In Sub ProcessTab, it's specifically this code that throws the error:

Run-time error '13': Type mismatch

ActiveSheet.Range(arr(i)).Select

strAddress = arr(0)

Run-time error '9': Subscript out of range

thisAddress = Split(strAddress, ":")(0)

I'm not sure what causes it, except that it's related to pressing TAB.

https://drive.google.com/file/d/1yL0pli6b1ymMZe33An2XLnG5U2J3ddQs/view?usp=sharing

[MSXL]

here again your workbook.http://www.vbaexpress.com/forum/showthread.php?70202-Setting-tab-order-adding-ability-to-stop-start-code-and-refine-functionality&p=416601&viewfull=1#post416601

I've been testing and come across a problem with text being copied to the clipboard being unreadable

Here is the output in Notepad++

30151

In Notepad it shows nothing.

I don't understand. So, I went back to the version that you shared and it's doing the same thing as the Notepad++ screenshot.

Does this happen for anyone else who tries the quoted download? What could be the cause?

[MSXL]

I've noticed that this seems to work fine in Office 2013 on Windows Server 2012 RS 64 Bit, but it's not working in Office 2019 on Windows 10 Home 64 bit. Any ideas?