Workbook Sheet Referncing Problem

Willow123

New Member
Joined
Dec 29, 2018
Messages
17
Good evening all,

I'm trying to make a program that will allow the user to click on a cell or select multiple cells and the contents of that cell, or a selection of cells, will then be pasted into another workbook. I'm using a selection change event to accomplish this. It works fine until I try to get it to paste into another workbook...then not so fine. Any thoughts would be appreciated.


Rich (BB code):
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim wb1 As Workbook, wb2 As Workbook, shxx As Worksheet, shx As Worksheet

Set wb1 = ActiveWorkbook
Set wb2 = Workbooks(2) 
Set shx = wb1.Sheets(1) 
Set shxx = wb2.Sheets(1) 

Cells.Interior.ColorIndex = 0
If IsEmpty(Target) Or Selection.Cells.Count > 10 Then Exit Sub
Application.ScreenUpdating = False

With Selection
Range(Selection, Selection.Offset(0, 1)).Select
Range(Cells(.Row, .CurrentRegion.Column), _
Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1)) _
.Interior.Color = vbCyan And Selection.Copy
Application.EnableEvents = False
shxx.Range("J65536").End(xlUp).Offset(1, 0).Select
shxx.Paste
Application.EnableEvents = True
End With

Application.ScreenUpdating = True
End Sub


 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
I hate worksheet change events. I can't see the value of this code but this code will copy every non blank and < 10 cells selection from your workbook to another wb named "Book(2)" in this example. The code checks for the existence of wb2, if it exist it opens the wb2 pastes the target and saves and closes. If wb2 doesn't exist it creates the wb2 then pastes the target and saves and closes. I don't understand what data you're trying to copy and where your trying to paste it? That color change thing is also puzzling? Anyways, this should get U started. HTH. Dave
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim wb1 As Workbook, wb2 As Workbook, shxx As Worksheet
Dim FSO As Object, Wb2str As String, Folderpath As String
Dim shx As Worksheet, Lastrow As Integer, Testobj As Object

If IsEmpty(Target) Or Selection.Cells.Count > 10 Then
Exit Sub
End If

Application.ScreenUpdating = False
Set wb1 = ActiveWorkbook
Folderpath = Application.ActiveWorkbook.Path
Wb2str = Folderpath & "\" & "Books(2).xlsx" '**** Change name to suit
Set FSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
Set Testobj = FSO.GetFile(Wb2str)
If Err.Number <> 0 Then
On Error GoTo 0
Set wb2 = Workbooks.Add
wb2.SaveAs Filename:=Folderpath & "\" & "Books(2)" '**** Change name to suit
Else
Set wb2 = Workbooks.Open(Wb2str)
End If
Set FSO = Nothing

Set shx = wb1.Sheets(1)
Set shxx = wb2.Sheets(1)

'copy target to wb2 "J" lastrow
With shxx
    Lastrow = .Range("J" & .Rows.Count).End(xlUp).Row
End With
Target.Copy
shxx.Cells(Lastrow + 1, "J").PasteSpecial Paste:=xlPasteValues, Transpose:=False

'?????????????????
'With Selection
'shx.Range(Selection, Selection.Offset(0, 1)).Select
'shx.Range(Cells(.Row, .CurrentRegion.Column), _
Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1)) _
.Interior.Color = vbCyan And .Copy
'Application.EnableEvents = False
'shxx.Range("J" & Lastrow + 1).Paste 'Select
'shxx.Paste
'Application.EnableEvents = True
'End With

Application.CutCopyMode = False
Application.ScreenUpdating = True
wb2.Close SaveChanges:=True
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,202
Members
448,554
Latest member
Gleisner2

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