创建一个宏，允许在转置模式下自动粘贴并删除选定的复制行

Question

请求用于创建宏的 VBA 代码，该宏允许在选定单元格中自动以转置模式粘贴并删除已复制的选定行。

数据如下

Ana 我想要数据：

Answer 1

请尝试使用下一个代码。它假设要处理的范围存在于 A:B 列中，并且第一行中有标题。它将从同一张纸“M2”开始返回。它可以轻松地适应以在不同的工作表中返回：

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 列中的 only 切片，则只需将

Set rng = ws.Range("A2:B" & lastR)

替换为

Set rng = Selection

。

我尝试评论所有的行。如果仍有不清楚的地方，请随时要求澄清。

作为一般观察，我回答你的问题是因为你是新人，不太了解社区

customs

。最好表现出一些自己解决问题的个人兴趣，并在无法解决问题后才询问。证明你自己的努力……这不应该是必须的，但这样做是件好事。不然我们帮助你的热情不会这么高......