Workbook Sheet Referncing Problem

[Willow123]

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.

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

 

[NdNoviceHlp]

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

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