blocks|key|1093905|text|您可以将PasteSpecial函数与Transpose:=True一起使用。例如：|type|unstyled|depth|inlineStyleRanges|offset|length|style|CODE|entityRanges|data|1093906|Range("A2:A5").Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial+Paste:=xlPasteAll,+Operation:=xlNone,+SkipBlanks:=False,+Transpose:=True|code-block|syntax|javascript|1093907|会转置A2:A5到E2|1093908|​|1093909|📷|atomic|1093910|1093911|entityMap|0|IMAGE|mutability|IMMUTABLE|imageUrl|https://developer.qcloudimg.com/http-save/yehe-900000/f2cd12c64994fae35627ef7cbad672b7.png|imageAlt^0|4|C|J|F|0|0|3|5|9|2|0|0|0|1|0|0|0^^$0|@$1|2|3|4|5|6|7|11|8|@$9|12|A|13|B|C]|$9|14|A|15|B|C]]|D|@]|E|$]]|$1|F|3|G|5|H|7|16|8|@]|D|@]|E|$I|J]]|$1|K|3|L|5|6|7|17|8|@$9|18|A|19|B|C]|$9|1A|A|1B|B|C]]|D|@]|E|$]]|$1|M|3|N|5|6|7|1C|8|@]|D|@]|E|$]]|$1|O|3|P|5|Q|7|1D|8|@]|D|@$9|1E|A|1F|1|1G]]|E|$]]|$1|R|3|N|5|6|7|1H|8|@]|D|@]|E|$]]|$1|S|3|-4|5|6|7|1I|8|@]|D|@]|E|$]]]|T|$U|$5|V|W|X|E|$Y|Z|10|-4]]]]

You can use the <code>PasteSpecial</code> function with <code>Transpose:=True</code>. For example:

<pre><code>Range("A2:A5").Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
</code></pre>

would transpose <code>A2:A5</code> to <code>E2</code>:

<a href="https://i.stack.imgur.com/5N3y3.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/5N3y3.png" alt="transpose col"></a>

blocks|key|1808093|text|首先，定义哪些行必须转置！是否只有第一行填充了值？还是数值是数字的？结果是在新工作表中还是在同一个工作表中？|type|unstyled|depth|inlineStyleRanges|entityRanges|data|1808094|您可以使用从第一行到最后一行的for循环：|1808095|查找插入转置范围的单元格。然后检查哪些范围必须转置。对要转置的第一行和最后一行使用长变量。当有值的新行出现时，剪切范围并将其粘贴到所需的单元格中。|1808096|您可以使用宏记录器来查看如何转换范围。或者看看其他的答案。|1808097|如果删除行，最好从底部到顶部创建新的工作表或循环。|1808098|entityMap^0|0|0|0|0|0^^$0|@$1|2|3|4|5|6|7|L|8|@]|9|@]|A|$]]|$1|B|3|C|5|6|7|M|8|@]|9|@]|A|$]]|$1|D|3|E|5|6|7|N|8|@]|9|@]|A|$]]|$1|F|3|G|5|6|7|O|8|@]|9|@]|A|$]]|$1|H|3|I|5|6|7|P|8|@]|9|@]|A|$]]|$1|J|3|-4|5|6|7|Q|8|@]|9|@]|A|$]]]|K|$]]

First define which rows have to be Transposed! Is there only the first row filled with values? Or are the values numeric? 
Is the result in a new or the same worksheet?

You can use a for loop from first row to last row: 

Find out the Cell where the transposed range is inserted. 
Then check which ranges have to be transposed. Use long variables for the first and last row You want to transpose. When a new row with values comes, cut the range and paste it into the desired cell

U can use the the macro recorder to see how to transpose a range. Or Look at the other answers.

If you delete the rows it is better to create a new Worksheet or Loop from bottom to Top

blocks|key|2274462|text|300,000行将需要一段时间来处理，但这可能会很快完成。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|2274463|Sub+duplicate()
++++Dim+rw+As+Long,+nrw+As+Long

++++Application.ScreenUpdating+=+False

++++With+Worksheets("Sheet1")+++'<~~+set+this+worksheet+properly!
++++++++For+rw+=+.Cells(Rows.Count,+1).End(xlUp).Row+To+2+Step+-1
++++++++++++If+Not+IsNumeric(.Cells(rw,+1).Value2)+Then
++++++++++++++++nrw+=+Application.Match(1E%2B99,+.Cells(1,+1).Resize(rw+-+1,+1))
++++++++++++++++.Cells(nrw,+Columns.Count).End(xlToLeft).Offset(0,+1)+=+.Cells(rw,+1).Value2
++++++++++++++++.Rows(rw).Delete
++++++++++++Else
++++++++++++++++With+.Rows(rw)
++++++++++++++++++++.Cells.Sort+Key1:=.Cells(1),+Order1:=xlAscending,+_
++++++++++++++++++++++++Orientation:=xlLeftToRight,+Header:=xlNo
++++++++++++++++End+With
++++++++++++End+If
++++++++Next+rw
++++End+With

++++Application.ScreenUpdating+=+True

End+Sub|code-block|syntax|javascript|2274464|可以通过处理变体内存数组来实现更快的处理，但这应该可以完成任务。|2274465|entityMap^0|0|0|0^^$0|@$1|2|3|4|5|6|7|K|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|L|8|@]|9|@]|A|$E|F]]|$1|G|3|H|5|6|7|M|8|@]|9|@]|A|$]]|$1|I|3|-4|5|6|7|N|8|@]|9|@]|A|$]]]|J|$]]

300,000 rows is going to take some time to process but this may run through fairly quickly.

<pre><code>Sub duplicate()
 Dim rw As Long, nrw As Long

 Application.ScreenUpdating = False

 With Worksheets("Sheet1") '&lt;~~ set this worksheet properly!
 For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
 If Not IsNumeric(.Cells(rw, 1).Value2) Then
 nrw = Application.Match(1E+99, .Cells(1, 1).Resize(rw - 1, 1))
 .Cells(nrw, Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 1).Value2
 .Rows(rw).Delete
 Else
 With .Rows(rw)
 .Cells.Sort Key1:=.Cells(1), Order1:=xlAscending, _
 Orientation:=xlLeftToRight, Header:=xlNo
 End With
 End If
 Next rw
 End With

 Application.ScreenUpdating = True

End Sub
</code></pre>

Faster processing could likely be achieved with processing variant memory arrays but this should get the job done.

blocks|key|1808190|text|我喜欢吉普解决方案，但它似乎重新排序的数据可能是不想要的。这是我提出的解决方案，我没有基准，所以我无法判断它是否真的慢。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|1808191|Public+Sub+Test()
++++Dim+lastRow+As+Long,+firstRow+As+Long,+lastCell+As+Range,+rng+As+Range
++++Dim+currentRow+As+Long
++++Application.ScreenUpdating+=+False
++++lastRow+=+Cells(Rows.Count,+1).End(xlUp).Row
++++For+currentRow+=+lastRow+To+1+Step+-1
++++++++If+IsNumeric(Cells(currentRow,+1).Value)+Then
++++++++++++Set+lastCell+=+Cells(currentRow,+1).End(xlToRight).Offset(0,+1)

++++++++++++Set+rng+=+Range(Cells(firstRow,+1),+Cells(lastRow,+1))
++++++++++++rng.Copy
++++++++++++lastCell.PasteSpecial+Transpose:=True
++++++++++++rng.EntireRow.Delete
++++++++++++lastRow+=+currentRow+-+1
++++++++Else
++++++++++++firstRow+=+currentRow
++++++++End+If
++++Next+currentRow
++++Application.ScreenUpdating+=+False
End+Sub|code-block|syntax|javascript|1808192|我想出了另一个混合吉普和我的版本：|1808193|Public+Sub+Test2(Optional+ws+As+Worksheet)
++++Dim+lastRow+As+Long,+lastCell+As+Range,+rng+As+Range
++++Dim+currentRow+As+Long

++++Application.ScreenUpdating+=+False

++++If+ws+Is+Nothing+Then+Set+ws+=+ActiveSheet

++++Dim+BigestValue+As+Variant
++++BigestValue+=+ws.Evaluate([MAX(A:A)])
++++lastRow+=+ws.Cells(Rows.Count,+1).End(xlUp).Row
++++For+currentRow+=+lastRow+To+1+Step+-1
++++++++If+Not+IsNumeric(ws.Cells(currentRow,+1).Value)+Then
++++++++++++'look+up+for+last+numeric+cell
++++++++++++lastRow+=+currentRow
++++++++++++currentRow+=+Application.Match(BigestValue,+ws.Cells(1,+1).Resize(currentRow,+1))
++++++++++++Set+lastCell+=+ws.Cells(currentRow,+1).End(xlToRight).Offset(0,+1)
++++++++++++Set+rng+=+Range(ws.Cells(currentRow+%2B+1,+1),+ws.Cells(lastRow,+1))
++++++++++++rng.Copy
++++++++++++lastCell.PasteSpecial+Transpose:=True
++++++++++++rng.EntireRow.Delete
++++++++End+If
++++Next+currentRow

++++Application.ScreenUpdating+=+True
End+Sub|1808194|entityMap^0|0|0|0|0^^$0|@$1|2|3|4|5|6|7|M|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|N|8|@]|9|@]|A|$E|F]]|$1|G|3|H|5|6|7|O|8|@]|9|@]|A|$]]|$1|I|3|J|5|D|7|P|8|@]|9|@]|A|$E|F]]|$1|K|3|-4|5|6|7|Q|8|@]|9|@]|A|$]]]|L|$]]

I liked Jeeped solution, but it seems to reorder the data witch might not be desired. Here is my proposed solution, I haven't benchmarked so I can't tell if it is really slower.

<pre><code>Public Sub Test()
 Dim lastRow As Long, firstRow As Long, lastCell As Range, rng As Range
 Dim currentRow As Long
 Application.ScreenUpdating = False
 lastRow = Cells(Rows.Count, 1).End(xlUp).Row
 For currentRow = lastRow To 1 Step -1
 If IsNumeric(Cells(currentRow, 1).Value) Then
 Set lastCell = Cells(currentRow, 1).End(xlToRight).Offset(0, 1)

 Set rng = Range(Cells(firstRow, 1), Cells(lastRow, 1))
 rng.Copy
 lastCell.PasteSpecial Transpose:=True
 rng.EntireRow.Delete
 lastRow = currentRow - 1
 Else
 firstRow = currentRow
 End If
 Next currentRow
 Application.ScreenUpdating = False
End Sub
</code></pre>

I've come up with another version mixing Jeeped and mine:

<pre><code>Public Sub Test2(Optional ws As Worksheet)
 Dim lastRow As Long, lastCell As Range, rng As Range
 Dim currentRow As Long

 Application.ScreenUpdating = False

 If ws Is Nothing Then Set ws = ActiveSheet

 Dim BigestValue As Variant
 BigestValue = ws.Evaluate([MAX(A:A)])
 lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
 For currentRow = lastRow To 1 Step -1
 If Not IsNumeric(ws.Cells(currentRow, 1).Value) Then
 'look up for last numeric cell
 lastRow = currentRow
 currentRow = Application.Match(BigestValue, ws.Cells(1, 1).Resize(currentRow, 1))
 Set lastCell = ws.Cells(currentRow, 1).End(xlToRight).Offset(0, 1)
 Set rng = Range(ws.Cells(currentRow + 1, 1), ws.Cells(lastRow, 1))
 rng.Copy
 lastCell.PasteSpecial Transpose:=True
 rng.EntireRow.Delete
 End If
 Next currentRow

 Application.ScreenUpdating = True
End Sub
</code></pre>

blocks|key|1085315|text|有了这么多数据，我觉得这个过程会执行得更快，就像Jeeped提到的那样，在VBA数组中执行，而不是在工作表上执行。这里有一个宏可以做到这一点。要知道从哪里开始一个新行，我看了第2列--如果第2列是空的，那么数据就追加到前一行；如果没有，那么新行就会开始。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|1085316|其他类型的测试也可以替代。|1085317|Option+Explicit
Sub+TransposeSomeRows()
++++Dim+wsSrc+As+Worksheet,+wsRes+As+Worksheet,+rRes+As+Range
++++Dim+vSrc+As+Variant,+vRes()+As+Variant
++++Dim+I+As+Long,+J+As+Long,+K+As+Long

++++Dim+lRowCount+As+Long,+lColCount+As+Long

Set+wsSrc+=+Worksheets("sheet1")
Set+wsRes+=+Worksheets("sheet2")
++++Set+rRes+=+wsRes.Cells(1,+1)

With+wsSrc.Cells
++++lRowCount+=+.Find(what:="*",+after:=.Item(1,+1),+LookIn:=xlValues,+_
++++++++searchorder:=xlByRows,+searchdirection:=xlPrevious).Row
++++lColCount+=+.Find(what:="*",+after:=.Item(1,+1),+_
++++++++searchorder:=xlByColumns,+searchdirection:=xlPrevious).Column
End+With

'Read+source+data+into+array
With+wsSrc
++++vSrc+=+.Range(.Cells(2,+1),+.Cells(lRowCount,+lColCount))
End+With

'create+results+array
'Num+of+rows+=+number+of+items+in+Column+2
lRowCount+=+WorksheetFunction.CountA(wsSrc.Columns(2))

'Num+of+columns+=+max+of+entries+in+a+"start+row"+plus+blanks+to+next+"start+row"
lColCount+=+0
For+I+=+1+To+UBound(vSrc,+1)
++++If+vSrc(I,+2)+<>+""+Then
++++++++For+J+=+1+To+UBound(vSrc,+2)
++++++++++++If+vSrc(I,+J)+<>+""+Then+K+=+J
++++++++Next+J
++++Else+'vSrc(i,2)+=+""+so+add+a+column
++++++++K+=+K+%2B+1
++++End+If

++++lColCount+=+IIf(lColCount+>+K,+lColCount,+K)

Next+I


ReDim+vRes(1+To+lRowCount,+1+To+lColCount)

'Populate+results+array
K+=+0
For+I+=+1+To+UBound(vSrc,+1)
++++If+vSrc(I,+2)+<>+""+Then
++++++++K+=+K+%2B+1
++++++++J+=+1
++++++++For+J+=+1+To+UBound(vSrc,+2)
++++++++++++If+vSrc(I,+J)+<>+""+Then
++++++++++++++++vRes(K,+J)+=+vSrc(I,+J)
++++++++++++Else
++++++++++++++++Exit+For
++++++++++++End+If
++++++++Next+J
++++Else
++++++++vRes(K,+J)+=+vSrc(I,+1)
++++++++J+=+J+%2B+1
++++End+If
Next+I

'Write+results+to+worksheet
Set+rRes+=+rRes.Resize(UBound(vRes,+1),+UBound(vRes,+2))
With+rRes
++++.EntireColumn.Clear
++++.Value+=+vRes
++++.EntireColumn.AutoFit
End+With

End+Sub|code-block|syntax|javascript|1085318|entityMap^0|0|0|0^^$0|@$1|2|3|4|5|6|7|K|8|@]|9|@]|A|$]]|$1|B|3|C|5|6|7|L|8|@]|9|@]|A|$]]|$1|D|3|E|5|F|7|M|8|@]|9|@]|A|$G|H]]|$1|I|3|-4|5|6|7|N|8|@]|9|@]|A|$]]]|J|$]]

With so much data, I felt the process would execute more rapidly, as Jeeped mentioned, done in VBA arrays instead of on the worksheet. Here is a macro that does that. To tell where to start a new row, I looked at column 2 -- if column 2 is blank, then the data is appended to the previous row; if not, then a new row would start.

Other types of testing could be substituted.

<hr>

<pre><code>Option Explicit
Sub TransposeSomeRows()
 Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
 Dim vSrc As Variant, vRes() As Variant
 Dim I As Long, J As Long, K As Long

 Dim lRowCount As Long, lColCount As Long

Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
 Set rRes = wsRes.Cells(1, 1)

With wsSrc.Cells
 lRowCount = .Find(what:="*", after:=.Item(1, 1), LookIn:=xlValues, _
 searchorder:=xlByRows, searchdirection:=xlPrevious).Row
 lColCount = .Find(what:="*", after:=.Item(1, 1), _
 searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
End With

'Read source data into array
With wsSrc
 vSrc = .Range(.Cells(2, 1), .Cells(lRowCount, lColCount))
End With

'create results array
'Num of rows = number of items in Column 2
lRowCount = WorksheetFunction.CountA(wsSrc.Columns(2))

'Num of columns = max of entries in a "start row" plus blanks to next "start row"
lColCount = 0
For I = 1 To UBound(vSrc, 1)
 If vSrc(I, 2) &lt;&gt; "" Then
 For J = 1 To UBound(vSrc, 2)
 If vSrc(I, J) &lt;&gt; "" Then K = J
 Next J
 Else 'vSrc(i,2) = "" so add a column
 K = K + 1
 End If

 lColCount = IIf(lColCount &gt; K, lColCount, K)

Next I


ReDim vRes(1 To lRowCount, 1 To lColCount)

'Populate results array
K = 0
For I = 1 To UBound(vSrc, 1)
 If vSrc(I, 2) &lt;&gt; "" Then
 K = K + 1
 J = 1
 For J = 1 To UBound(vSrc, 2)
 If vSrc(I, J) &lt;&gt; "" Then
 vRes(K, J) = vSrc(I, J)
 Else
 Exit For
 End If
 Next J
 Else
 vRes(K, J) = vSrc(I, 1)
 J = J + 1
 End If
Next I

'Write results to worksheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
 .EntireColumn.Clear
 .Value = vRes
 .EntireColumn.AutoFit
End With

End Sub
</code></pre>

<hr>

I googled this question, but nothing reasonalbe didn't pop out, and i don't have any clue, at the moment, how to do it. So, decided to write here. 

I have large table, aprox. 300'000 rows, and between normal rows, i have some information, which needs to be transposed to rows. 
As a sample, this information looks like this:

<a href="https://i.stack.imgur.com/XHfEB.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/XHfEB.png" alt="enter image description here"></a>

If any ideas pops out, please, let me know. 
Best regards.

VBA transpose rows of data into columns

翻译质量差，导致语言生硬或混乱。

没有提供实际的解决方法或示例。

解答不清晰，无法理解或解决问题。

页面排版不美观，阅读体验差。

文章

问答

视频

学习中心

腾讯云实验室

直播

竞赛

腾讯云代码分析专区

腾讯iOA零信任安全管理系统专区

腾讯云架构师技术同盟交流圈

腾讯云数据库专区

腾讯云顾问专区

腾讯云原生专区

腾讯混元专区

腾讯云TCE专区

腾讯云Lighthouse专区

腾讯云HAI专区

腾讯云Edgeone专区

腾讯云存储专区

腾讯云智能专区

腾讯轻联专区 

腾讯云开发专区

TAPD专区

腾讯轻量云游戏服专区

腾讯云最具价值专家

腾讯云架构师技术同盟

腾讯云创作之星

腾讯云开发者先锋 

腾讯云代码助手

CODING DevOps

Cloud Studio

SDK中心

API中心

命令行工具

我在谷歌上搜索了这个问题，但没有什么reasonalbe没有弹出，我现在也不知道该如何做。所以决定在这里写。我有一张大桌子。300'000行，在普通行之间，我有一些信息，需要转换为行。作为一个示例，这些信息如下所示：​​如果有什么想法，请告诉我。诚挚的问候。

问VBA将数据行转换为列。
EN

Stack Overflow用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问VBA将数据行转换为列。EN