Transfer data from one worksheet to another

[ipbr21054]

Evening,
I have a worksheet called DATABASE & another called KEYCODES

I am looking for a way to copy some values from the DATABASE worksheet to the KEYCODES worksheet.
I will be working from the DATABASE worksheet when i do this.

Some information for you.
Path to KEYCODES worksheet is C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\KEYCODES.xlsm

The values to be copied from DATABASE worksheet will be Column D C J K
They will then need to be entered into the KEYCODES database Columns A B C D
So
DATABASE D to KEYCODES A
DATABASE C to KEYCODES B
DATABASE J to KEYCODES C
DATABASE K to KEYCODES D


There are values currently on the KEYCODES worksheet so when pasted it will need to add to bottom of current list
My issue is how to go about it

Thanks

 

[rlv01]

One way.

Sub CopyStuff()
    Dim WB As Workbook, DestWB As Workbook
    Dim WS As Worksheet, DestWS As Worksheet
    Dim rng As Range, rngDest As Range
    Dim ColArr As Variant, SCol As Variant, DCol As Variant
    
    On Error Resume Next
    Set DestWB = Application.Workbooks("KEYCODES.xlsm")
    On Error GoTo 0
    If DestWB Is Nothing Then
        MsgBox "Please open workbook XXX before running this macro"
        Exit Sub
    End If
    
    Set WB = ThisWorkbook
    On Error Resume Next
    Set WS = WB.Worksheets("DATABASE")
    On Error GoTo 0
    If WS Is Nothing Then
        MsgBox "Worksheet 'DATABASE' is missing"
        Exit Sub
    End If
    
    Set DestWS = DestWB.Worksheets("KEYCODES")
    ColArr = Array("D:A", "C:B", "J:C", "K:D")
    
    Application.ScreenUpdating = False
    For Each SCol In ColArr
        DCol = Split(SCol, ":")(1)
        SCol = Split(SCol, ":")(0)
        With WS
            Set rng = .Range(SCol & 1, .Range(SCol & .Rows.Count).End(xlUp))            'alternate
        End With
        With DestWS
            If IsEmpty(.Range(DCol & 1)) Then
                Set rngDest = .Range(DCol & 1)
            Else
                Set rngDest = .Range(DCol & .Rows.Count).End(xlUp).Offset(1)
            End If
        End With
        
        rng.Copy
        rngDest.PasteSpecial Paste:=xlPasteAll
    Next SCol
    Application.ScreenUpdating = True
End Sub

 

[ipbr21054]

How would i apply this to work ?
I dont see how i select my required value to then transfer it & the other cells value

For instance i need to copy the values from row say 22
then say 37 etc etc

 

[ipbr21054]

Maybe something like,
Double click value in column C to then copy the values from C D J K from the same row to the otherworksheet
BUT
If if the double click wasnt in column C then exit sub

The user would then move to the next row that he needs to transfer values over.

He would then continue down the page selecting as he goes.

Thanks

 

[ipbr21054]

As a test i put the code on a command button.
I added code to open the destination workbook.

When the code is run i get a RTE 91 Object variable or with block variable not set & debugs to the red line as shown.

Private Sub CommandButton1_Click()
    Dim WB As Workbook, DestWB As Workbook
    Dim WS As Worksheet, DestWS As Worksheet
    Dim rng As Range, rngDest As Range
    Dim ColArr As Variant, SCol As Variant, DCol As Variant
    
    On Error Resume Next
    Set DestWB = Application.Workbooks("KEY CODES.xlsm")
    On Error GoTo 0
    Workbooks.Open fileName:="C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\KEY CODES.xlsm"
    Workbooks("KEY CODES.xlsm").Activate

    
    Set WB = ThisWorkbook
    On Error Resume Next
    Set WS = WB.Worksheets("DATABASE")
    On Error GoTo 0
    If WS Is Nothing Then
        MsgBox "Worksheet 'DATABASE' is missing"
        Exit Sub
    End If
    
    Set DestWS = DestWB.Worksheets("KEYCODES")
    ColArr = Array("D:A", "C:B", "J:C", "K:D")
    
    Application.ScreenUpdating = False
    For Each SCol In ColArr
        DCol = Split(SCol, ":")(1)
        SCol = Split(SCol, ":")(0)
        With WS
            Set rng = .Range(SCol & 1, .Range(SCol & .Rows.Count).End(xlUp))            'alternate
        End With
        With DestWS
            If IsEmpty(.Range(DCol & 1)) Then
                Set rngDest = .Range(DCol & 1)
            Else
                Set rngDest = .Range(DCol & .Rows.Count).End(xlUp).Offset(1)
            End If
        End With
        
        rng.Copy
        rngDest.PasteSpecial Paste:=xlPasteAll
    Next SCol
    Application.ScreenUpdating = True
End Sub

 

[ipbr21054]

So i have no added the code for the doubcle click BUT now stopped & await your help to the issue as mentioned above & to only transfer values on that row

  Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

   If Not Intersect(Range("C6", Cells(Rows.Count, "C").End(xlUp)), Target) Is Nothing Then
    Cancel = True
    Dim WB As Workbook, DestWB As Workbook
    Dim WS As Worksheet, DestWS As Worksheet
    Dim rng As Range, rngDest As Range
    Dim ColArr As Variant, SCol As Variant, DCol As Variant
    
    On Error Resume Next
    Set DestWB = Application.Workbooks("KEY CODES.xlsm")
    On Error GoTo 0
    Workbooks.Open fileName:="C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\KEY CODES.xlsm"
    Workbooks("KEY CODES.xlsm").Activate

    Set WB = ThisWorkbook
    On Error Resume Next
    Set WS = WB.Worksheets("DATABASE")
    On Error GoTo 0
    If WS Is Nothing Then
        MsgBox "Worksheet 'DATABASE' is missing"
        Exit Sub
    End If
    
    Set DestWS = DestWB.Worksheets("KEYCODES")
    ColArr = Array("D:A", "C:B", "J:C", "K:D")
    
    Application.ScreenUpdating = False
    For Each SCol In ColArr
        DCol = Split(SCol, ":")(1)
        SCol = Split(SCol, ":")(0)
        With WS
            Set rng = .Range(SCol & 1, .Range(SCol & .Rows.Count).End(xlUp))            'alternate
        End With
        With DestWS
            If IsEmpty(.Range(DCol & 1)) Then
                Set rngDest = .Range(DCol & 1)
            Else
                Set rngDest = .Range(DCol & .Rows.Count).End(xlUp).Offset(1)
            End If
        End With
        
        rng.Copy
        rngDest.PasteSpecial Paste:=xlPasteAll
    Next SCol
    Application.ScreenUpdating = True
   End If
End Sub

 

[Alex Blakenburg]

You are setting the DestWB before opening the workbook.'
Also you now only want to copy the selected row.

Try this.
Changed sections in Blue

  Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

   If Not Intersect(Range("C6", Cells(Rows.Count, "C").End(xlUp)), Target) Is Nothing Then
    Cancel = True
    Dim WB As Workbook, DestWB As Workbook
    Dim WS As Worksheet, DestWS As Worksheet
    Dim rng As Range, rngDest As Range
    Dim ColArr As Variant, SCol As Variant, DCol As Variant
   
    On Error Resume Next
    Set DestWB = Application.Workbooks("KEY CODES.xlsm")

    If DestWB Is Nothing Then
        Workbooks.Open Filename:="C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\KEY CODES.xlsm"
        Set DestWB = Application.Workbooks("KEY CODES.xlsm")
    End If
    On Error GoTo 0

    Set WB = ThisWorkbook
    On Error Resume Next
    Set WS = WB.Worksheets("DATABASE")
    On Error GoTo 0
    If WS Is Nothing Then
        MsgBox "Worksheet 'DATABASE' is missing"
        Exit Sub
    End If
   
    Set DestWS = DestWB.Worksheets("KEYCODES")
    ColArr = Array("D:A", "C:B", "J:C", "K:D")
   
    Application.ScreenUpdating = False
    For Each SCol In ColArr
        DCol = Split(SCol, ":")(1)
        SCol = Split(SCol, ":")(0)
        With WS
            Set rng = .Cells(Target.Row, SCol)
        End With
        With DestWS
            If IsEmpty(.Range(DCol & 1)) Then
                Set rngDest = .Range(DCol & 1)
            Else
                Set rngDest = .Range(DCol & .Rows.Count).End(xlUp).Offset(1)
            End If
        End With
       
        rng.Copy
        rngDest.PasteSpecial Paste:=xlPasteAll
    Next SCol
    Application.ScreenUpdating = True
   End If
End Sub

 

[ipbr21054]

Im out at present so will check once home.

Regarding you mention I now want to copy the row, that is not the case.

I don’t want to copy the row.
The row is say column A through to say column Z
I only wish to copy cell values from the columns mentioned in my first post.

Example.
I say double click cell C99 I then wish the code to copy not only that cells value BUT also D99 J99 K99 cell value to worksheet & columns mentioned.

I might then also do the same for say cell C123 then the same process would apply.

 

[Alex Blakenburg]

The original request says nothing about selecting a row and only identifies the colums to copy. Therefore rlv01's code is copying all rows for those columns.
Your code is using that same logic and copying all the rows for those columns.
I have modified it to copy only the selected row for those columns.

 

[ipbr21054]

The code in post # 7 did the trick many thanks.
One thing i forgot to mention & only just spotted myself is cell C Has a drop down formula so when i transfer the value it wanst me to rename it & it then pastes the formula also.
Can i ask please that we just transfer the cell value over

Have a nice day