Copy specific cell to new worksheet but keep original cell value

Haytham Amairah
Silver Contributor
Apr 16, 2018
Hi,

The solution is powered by this code:
Sub test()
On Error Resume Next
Application.ScreenUpdating = False

Dim r1, r2 As Integer

r1 = Application.WorksheetFunction.CountA(Sh2.Range("B:B"))
r2 = Application.WorksheetFunction.CountA(Sh2.Range("E:E"))

Sh2.Range("B1").Offset(r1).Value = Sh1.Range("B2").Value
Sh2.Range("E1").Offset(r2).Value = Sh1.Range("E2").Value
Sh2.Activate
Sh2.Range("E1").Offset(r2).Select

Application.ScreenUpdating = True
On Error GoTo 0
End Sub

This is the explanation of the code (line by line):

To prevent any error message from appearing
On Error Resume Next

To turn off the screen updates and flickers that can appear while the code is running
Application.ScreenUpdating = False

To count the numbers of the non-blanks cells in column B of the sheet 2 and assign it to the variable r1
r1 = Application.WorksheetFunction.CountA(Sh2.Range("B:B"))

To count the numbers of the non-blanks cells in column E of the sheet 2 and assign it to the variable r2
r2 = Application.WorksheetFunction.CountA(Sh2.Range("E:E"))

The below code sets the focus on the cell B1 of the Sheet 2, and go down (offset) by the number of the non-blanks cells in column B of the Sheet 2, and then it assigns the value of the cell B2 of the sheet 1 to the new cell in column B of the Sheet 2.
NOTE: The number the non-blanks cells is already assigned to the variable r1, so I passed this variable to the Offset function: Offset(r1).
Sh2.Range("B1").Offset(r1).Value = Sh1.Range("B2").Value

This is the same code above but for the column E of the Sheet 2
Sh2.Range("E1").Offset(r2).Value = Sh1.Range("E2").Value

To activate the Sheet 2
Sh2.Activate

To select the last filled cell in column E of the Sheet2 after the process is finished
NOTE: This code is bonus and you can delete it!
Sh2.Range("E1").Offset(r2).Select

These are the last two lines which are used to restore the default status of the screen updating and error handling
Application.ScreenUpdating = True
On Error GoTo 0

I hope this is clear enough
Haytham
Move_Specific_Cells_To_Another_Sheet.xls42 KB
- yamingy
  Copper Contributor
  Jun 16, 2020
  Hi Haytham Amairah! I found this to be super helpful, but I want to do this for multiple columns (D to BB). I'm new to VBA, so I'm not sure how to iterate through columns. Can you offer some pointers? Thanks in advance!
- hopr37 hotmail
  Brass Contributor
  Apr 16, 2018
  Thank you so much. I figured out what I was doing wrong so I have the original formula working.
  Sh2.Range
  I had to change that to: Sheets("the name of my sheet").Range
  
  Now I'll look over what you just posted and get back to you.
  I really appreciate the help.
  
  Is it simply to make a change so that ANY value that is changed in column B and column E would do the same?
  - Haytham Amairah
    Silver Contributor
    Apr 16, 2018
    Do you mean that you want to get rid of using the button and make this code triggers in case if the cell B2 or E2 of the Sheet 1 is changed?
    
    If so, please right-click the Sheet 1 tab and choose View Code, and then copy and paste this code there:
    Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.ScreenUpdating = False
    
    If Not Intersect(Target, Range("B2, E2")) Is Nothing Then
    
    Dim r1, r2 As Integer
    
    r1 = Application.WorksheetFunction.CountA(Sh2.Range("B:B"))
    r2 = Application.WorksheetFunction.CountA(Sh2.Range("E:E"))
    
    Sh2.Range("B1").Offset(r1).Value = Sh1.Range("B2").Value
    Sh2.Range("E1").Offset(r2).Value = Sh1.Range("E2").Value
    Sh2.Activate
    Sh2.Range("E1").Offset(r2).Select
    
    End If
    
    Application.ScreenUpdating = True
    On Error GoTo 0
    End Sub

Forum Discussion

Copy specific cell to new worksheet but keep original cell value

Resources