Automate Copy Paste Data in Non Adjacent Cells in Sheet1 to Sheet2 with VBA

How can we automatically copy paste data in non adjacent cells in Sheet1 to Sheet2 using Excel VBA?
If you try to copy multiple data in random cells by selecting the cells while keeping Ctrl key pressed and paste them on another sheet you get an error message:

Copy Paste Non Adjacent Cells in Excel
Copy Paste Non Adjacent Cells in Excel

We can, of course, perform the copy and paste procedure step by step but that would be a tedious process. Visual Basic for Applications comes to our help. We can perform the copy paste quickly and easily by using a looping process like a ‘for next’ loop. By modifying the VBA code inside the loop carefully we can:

  1. Copy the data from sheet1 to sheet2 to exactly the came cell addresses (not very useful)
  2. Copy the non-continuous data from sheet1 to sheet2 in adjacent columns
  3. Copy the non-adjacent data from sheet1 to sheet2 in adjacent rows one below the other

This can be quite useful where we have important data scattered all over the worksheet and we wish to bring the data adjacent to each other and compare it with standard data quickly and easily to take a decision, for example, of giving a loan to company if we are a financial institution.
Watch the training video before you study the VBA code:

Watch the Excel VBA training video on YouTube.
Download a sample file:

Here’s the complete VBA code:
Sub test()
‘declare the variables
Dim copyRange As Range, cel As Range, pasteRange As Range, erow As Long, ecolumn As Long
‘we use the set keyword to create a new object
Set copyRange = ThisWorkbook.Sheets(“Sheet1”).Range(“A2,B4,D5,E1,F3”)
Set pasteRange = ThisWorkbook.Sheets(“Sheet2”).Range(“A1”)
‘start a looping process to copy and paste non-adjacent cells
For Each cel In copyRange
‘erow defines the next blank row
erow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row
‘ecolumn defines the next blank column
‘ecolumn = Sheet2.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).column
pasteRange.Cells(erow, 1).PasteSpecial xlPasteValues
‘Range(cel.Address) pastes the data using the original address of the copied data
‘pasteRange.Range(cel.Address).PasteSpecial xlPasteValues

‘remove the ant-like selection
Application.CutCopyMode = False
End Sub

Further reading:
Copying and pasting non-adjacent cells
KB0160: Copying a multi-selection of non-adjacent cells into the think-cell data sheet does not work