Results 1 to 2 of 2

Thread: Workbook Sheet Referncing Problem
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Dec 2018
    Posts
    15
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Workbook Sheet Referncing Problem

    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.


    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
    



  2. #2
    Board Regular NdNoviceHlp's Avatar
    Join Date
    Nov 2002
    Location
    Manitoba Canada
    Posts
    2,283
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Workbook Sheet Referncing Problem

    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

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •