Скопируйте несмежные ячейки и вставьте транспонирование, но не во всю строку

Question

Лист

Код

В начале кода TargetRow имеет значение 0. При выполнении TargetRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1, значение равно 2. При повторном запуске сценария TargetRow снова начинается с 0.

Sub TransferData()

Dim wsSource As Worksheet  'define source worksheet
Set wsSource = Worksheets("Form")

Dim wsTarget As Worksheet  'define target worksheet
Set wsTarget = Worksheets("DB")

Dim TargetRow As Long 'don't use Integer. Excel has more rows than Integer can handle.
TargetRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1 'last used row + 1

'copy ticket data
wsSource.Range("TicketData").Copy
wsTarget.Range("F" & TargetRow).PasteSpecial Paste:=xlValues, Transpose:=True

'copy scores
wsSource.Range("Scores").Copy
wsTarget.Range("Q" & TargetRow).PasteSpecial Paste:=xlValues, Transpose:=True

End Sub

Answer 1

Я полагаю, вы хотели вставить в тот же ряд.Поэтому я предлагаю сначала определить следующую пустую строку только один раз, а затем использовать ее для обоих действий копирования / вставки.

Dim wsSource As Worksheet  'define source worksheet
Set wsSource = Worksheets("Form")

Dim wsTarget As Worksheet  'define target worksheet
Set wsTarget = Worksheets("DB")

Dim TargetRow As Long 'don't use Integer. Excel has more rows than Integer can handle.
TargetRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1 'last used row + 1

'copy ticket data
wsSource.Range("TicketData").Copy
wsTarget.Range("A" & TargetRow).PasteSpecial Paste:=xlValues, Transpose:=True

'copy scores
wsSource.Range("Scores").Copy
wsTarget.Range("R" & TargetRow).PasteSpecial Paste:=xlValues, Transpose:=True