VBA Code to copy a fixed number of cells from a row in one sheet to paste to a diagonal in pairs to another sheet.

[Marvalisa]

To start I first locate the row in the first sheet through MsgBox.

.Range(.cells(r, 2), .Cells(r, 2))

Next, I want to copy that row starting at column 5 through 18,

then I want to paste to another sheet in pairs along a diagonal.
For example, col 5 and 6 would paste to row 5 column b and c; col 7 and 8 would post to row 6 column d and e.

I can do this in a very naive way that is not efficient. I could copy col 5 and 6 then paste and repeated the process until done.
I was trying to set up a loop but I could not get it to work correctly. Any help would be greatly appreciated.

Here is a clip of my naive VBA code.
.Range(.Cells(r, 5), .Cells(r, 6)).Copy wsSR.Range("B5:C5")
.Range(.Cells(r, 7), .Cells(r, 8)).Copy wsSR.Range("D6:E6")
.Range(.Cells(r, 9), .Cells(r, 10)).Copy wsSR.Range("F7:G7")
.Range(.Cells(r, 11), .Cells(r, 12)).Copy wsSR.Range("H8:I8")
.Range(.Cells(r, 13), .Cells(r, 14)).Copy wsSR.Range("J9:K9")
.Range(.Cells(r, 15), .Cells(r, 16)).Copy wsSR.Range("L10:M10")
.Range(.Cells(r, 17), .Cells(r, 18)).Copy wsSR.Range("N11:O11")

There must be a way to grab the information once from one worksheet,
then paste into another without going back and forth each time which is slow as molasses.

 

[Peter_SSs]

Is it really only the values you are trying to copy or are you wanting to copy formulas, formatting data validation etc?
If only values, then try this sort of idea.

Sub CopyToDiagonal()
  Dim data As Variant
  Dim i As Long
  
  data = Sheets("Sheet1").Range("E2:R2").Value
  For i = 1 To UBound(data, 2) Step 2
    Sheets("Sheet2").Cells(5 + (i - 1) / 2, 1 + i).Resize(, 2).Value = Application.Index(data, 1, Array(i, i + 1))
  Next i
End Sub

Marvalisa 2020-03-21 1.xlsm
	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1
2		1	2	3	4	5	6	7	8	9	10	11	12	13	14
3
Sheet1

Marvalisa 2020-03-21 1.xlsm
	B	C	D	E	F	G	H	I	J	K	L	M	N	O
4
5	1	2
6			3	4
7					5	6
8							7	8
9									9	10
10											11	12
11													13	14
12
Sheet2

 

[Marvalisa]

Wow! It worked perfectly in the example you gave but my implementation didn't go quite as well. There is a lot packed into the few lines of code you gave. I thought I would just give a quick try and see if I couldn't get it to work then unpack what everything means after.
Here is what I inserted into my code:
data = .Range(.Cells(r, 5), .Cells(r, 18)).Value
For i = a To UBound(data, 2) Step 2
wsSR.Cells(5 + (i - 1) / 2, 1 + i).Resize(, 2).Value = Application.Index(data, 1, Array(i + 1))
Next i

 

[Marvalisa]

Wow! It worked perfectly in the example you gave but my implementation didn't go quite as well. There is a lot packed into the few lines of code you gave. I thought I would just give a quick try and see if I couldn't get it to work then unpack what everything means after.
Here is what I inserted into my code:
data = .Range(.Cells(r, 5), .Cells(r, 18)).Value
For i = a To UBound(data, 2) Step 2
wsSR.Cells(5 + (i - 1) / 2, 1 + i).Resize(, 2).Value = Application.Index(data, 1, Array(i + 1))
Next i

It seems rows and columns are off by 1 when I run the my program. I am not sure because I don't understand the code just yet. This is the data from the first sheet.

Here is the result I got:

 

[Marvalisa]

Thanks, Peter I found my mistakes and everything works as it should. I appreciate your help. I will try and understand what you done.
Marvalisa

 

[Peter_SSs]

Thanks, Peter I found my mistakes and everything works as it should. I appreciate your help.

You're welcome. Glad you got it sorted.