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]

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

Please keep in mind that I only know what you choose to tell me, so you should try to include requirements like this in your original post instead of waiting until after you get a response. That saves time for everyone. Because there was no information in your OP about choosing data subsets in DATABASE columns D C J K, my code copies all values in DATABASE columns D C J K to the end of KEYCODES columns A B C D respectively.

 

[ipbr21054]

I thought that what i put about row & column letters suggested that buy my bad sorry & thanks for the reply

 

[Alex Blakenburg]

Can i ask please that we just transfer the cell value over

There are a couple of ways of doing that, one way is to simply replace the xlPasteAll to xlPasteValues.

rngDest.PasteSpecial Paste:=xlPasteValues

 

[ipbr21054]

Morning,
Today i started to try & copy values from DATABASE to KEYCODE but came across an issue.
Code in use is shown below.

I double clicked cell in column C
I see the code run & complete.
I open KEYCODES to see what it had done & i see the following.
The values had been correctrly copied / pasted to columns ABC in this case was at Row 35 BUT the value that should of been pasted to D35 was actually put in cell D2

See attached screenshots

  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:=xlPasteValues
        rngDest.Borders.Weight = xlThin
        rngDest.Font.Size = 14
        rngDest.Font.Bold = True
        rngDest.HorizontalAlignment = xlCenter
        rngDest.Cells.Interior.ColorIndex = 6
        rngDest.Cells.RowHeight = 25
    Next SCol
    Application.ScreenUpdating = True
   End If
 
   Application.DisplayAlerts = False
   ActiveWorkbook.Close _
   SaveChanges:=True, _
   fileName:="C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\KEY CODES.xlsm"
   Application.DisplayAlerts = True
 
End Sub

 

[Alex Blakenburg]

Give this a try, code changes 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")
 
    Dim DestNextRow As Long
    With DestWS
        If IsEmpty(.Range("A" & 1)) Then
            DestNextRow = 1
        Else
            DestNextRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        End If
    End With

    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
            Set rngDest = .Range(DCol & DestNextRow)
        End With

        rng.Copy
        rngDest.PasteSpecial Paste:=xlPasteValues
    Next SCol
    Application.ScreenUpdating = True
   End If
 
   Application.DisplayAlerts = False
   ActiveWorkbook.Close _
   SaveChanges:=True, _
   Filename:="C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\KEY CODES.xlsm"
   Application.DisplayAlerts = True
 
End Sub

 

[ipbr21054]

So with the alteration mentioned above now this is the code in use.

I double click the valuue in cell C & i see a Compile Error Next Without For.
I debug & red text in code is shown.

  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")
   
    Dim DestNextRow As Long
        With DestWS
            Set rngDest = .Range(DCol & DestNextRow)
        End With
       
        rng.Copy
        rngDest.PasteSpecial Paste:=xlPasteValues
        rngDest.Borders.Weight = xlThin
        rngDest.Font.Size = 14
        rngDest.Font.Bold = True
        rngDest.HorizontalAlignment = xlCenter
        rngDest.Cells.Interior.ColorIndex = 6
        rngDest.Cells.RowHeight = 25
    Next SCol
    Application.ScreenUpdating = True
   End If
   
   Application.DisplayAlerts = False
   ActiveWorkbook.Close _
   SaveChanges:=True, _
   fileName:="C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\KEY CODES.xlsm"
   Application.DisplayAlerts = True
End Sub

 

[Alex Blakenburg]

Please use my entire code as is.
Don't try and modify yours for the changes.

 

[ipbr21054]

I thought reading you reply i had to replace my code JUST with the blue code.
Ok so i need to replace it all BUt some of the code has been left out.

see here.

        rng.Copy
        rngDest.PasteSpecial Paste:=xlPasteValues
        rngDest.Borders.Weight = xlThin
        rngDest.Font.Size = 14
        rngDest.Font.Bold = True
        rngDest.HorizontalAlignment = xlCenter
        rngDest.Cells.Interior.ColorIndex = 6
        rngDest.Cells.RowHeight = 25

 

[Alex Blakenburg]

See if this now has everything:

  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")
    
    Dim DestNextRow As Long
    With DestWS
        If IsEmpty(.Range("A" & 1)) Then
            DestNextRow = 1
        Else
            DestNextRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        End If
    End With
    
    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
            Set rngDest = .Range(DCol & DestNextRow)
        End With

        rng.Copy
        rngDest.PasteSpecial Paste:=xlPasteValues
        
        rngDest.Borders.Weight = xlThin
        rngDest.Font.Size = 14
        rngDest.Font.Bold = True
        rngDest.HorizontalAlignment = xlCenter
        rngDest.Cells.Interior.ColorIndex = 6
        rngDest.Cells.RowHeight = 25
    Next SCol
    Application.ScreenUpdating = True
   End If
 
   Application.DisplayAlerts = False
   ActiveWorkbook.Close _
   SaveChanges:=True, _
   Filename:="C:\Users\Ian\Desktop\REMOTES ETC\DR\EXCEL WORKSHEETS\KEY CODES.xlsm"
   Application.DisplayAlerts = True
 
End Sub