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

Пожалуйста, попробуйте использовать следующий код. Предполагается, что обрабатываемый диапазон существует в столбцах A:B, а в первой строке есть заголовки. Он вернется, начиная с «М2», того же листа. Его можно легко адаптировать для возврата на другом листе:

Sub copyTransposeDelete()
  Dim ws As Worksheet, lastR As Long, rng As Range, arr, arrIt, arrFin
  Dim i As Long, maxCol As Long, j As Long, dict As Object
  
  Set ws = ActiveSheet 'use here the necessary sheet
  lastR = ws.Range("A" & ws.rows.count).End(xlUp).row 'last row on A:A column
  Set rng = ws.Range("A2:B" & lastR) 'the range to be processed/deleted
  
  arr = rng.Value2 'place the range in an array for faster processing (in memory)
  
  Set dict = CreateObject("Scripting.Dictionary") 'set the necessary dictionary
  
  'load the dictionary with unique keys and all items for the same key:
  For i = 1 To UBound(arr) 'iterate between the array rows:
    If Not dict.Exists(arr(i, 1)) Then       'if dictionary key does not exist, create it
        dict.Add arr(i, 1), Array(arr(i, 2)) 'create it, with B:B value in an array
    Else                                     'if it exists:
        arrIt = dict(arr(i, 1))              'place the item in an array to update it
        ReDim Preserve arrIt(UBound(arrIt) + 1) 'increase the number of elements by one, preserving existig
        arrIt(UBound(arrIt)) = arr(i, 2)        'load the value from B:B in the last array element
        dict(arr(i, 1)) = arrIt                 'place back the updated array as item
        If maxCol < UBound(arrIt) + 1 Then maxCol = UBound(arrIt) + 1 'determine maximum necessary number of columns
    End If
  Next i
  
  If maxCol = 0 Then maxCol = 1 'if only one element (1D array), make it 1 (2D array)
  ReDim arrFin(1 To dict.count, 1 To maxCol + 1) 'redim the final array to keep all possible columns
  For i = 0 To dict.count - 1   'iterate between the dictionary elements
    arrFin(i + 1, 1) = dict.keys()(i)            'place the key in the first column
    For j = 0 To UBound(dict.Items()(i))
        arrFin(i + 1, j + 2) = dict.Items()(i)(j) 'place each element of item array in its column
    Next j
  Next i
  
  'drop the final array content, at once
  ws.Range("M2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin
  
  'delete the used range (rng)
  rng.Select 'it now only selects it. if the code works as you need you have to
             'replace Select with Clear
End Sub

Теперь он выбирает только используемый диапазон для обработки. Как было сказано выше, если вас устраивает возврат кода, вам необходимо заменить Selecgt на Clear.

Если вам действительно нужно обработать только фрагменты из столбца A:B, полученные вручную, вам следует заменить только Set rng = ws.Range("A2:B" & lastR) на Set rng = Selection.

Я пробовал комментировать все строки. Если что-то еще не совсем ясно, не стесняйтесь обращаться за разъяснениями.

И как общее наблюдение, я ответил на ваш вопрос, потому что вы новичок, не очень хорошо знающий сообщество customs. Хорошо проявить личный интерес к решению проблемы самостоятельно и спрашивать только после того, как вы не смогли ее решить. Доказательство собственных усилий... Это не должно быть обязательным, но это полезно сделать. В противном случае наш энтузиазм в помощи Вам будет не таким высоким...