[英](VBA) Excel with thousands of rows - how to transpose variable length columns to rows?
I have an Excel sheet I am working with 9948 rows. 我有一个Excel工作表,正在处理9948行。 A cell would have multiple pieces of information contained within it so what I've done so far is delimit those through Excel's text-to-column feature.
一个单元格中将包含多条信息,因此到目前为止,我所做的是通过Excel的“文本到列”功能对这些信息进行定界。
(All data and column headers are arbitrary) (所有数据和列标题都是任意的)
It started out like this: 它开始像这样:
ID | Name | Property1 |
1 Apple JO18, GFBAJH, HFDH, 78EA
It has data (in mixed text/number format) in the first couple columns that should actually be on their own row. 它在前几列中具有数据(采用文本/数字混合格式),该数据实际上应位于其自己的行上。 The amount of properties one of these have varies so one might have five properties and another might have 20. It looks something like this after I've delimited the rows:
这些属性之一的属性数量各不相同,因此一个属性可能具有五个属性,另一个属性可能具有20个属性。在分隔行之后,它看起来像这样:
ID | Name | Property1| Property2 | Property3 | Property4 | Property5 | Property6 |
1 Apple J012 B83A G5DD
2 Banana RETB 7CCV
3 Orange QWER TY YUIP CVBA UBBN FDRT
4 Pear 55V DWZA 6FJE LKOI PAKD
5 Cherry EEF AGC TROU
What I've been trying to accomplish is to get it to look like this: 我一直试图实现的目标是使其看起来像这样:
ID | Name | Property1| Property2 | Property3 | Property4 | Property5 | Property6 |
1 Apple J012
B83A
G5DD
2 Banana RETB
7CCV
3 Orange QWER
TY
YUIP
CVBA
UBBN
FDRT
4 Pear 55V
DWZA
6FJE
LKOI
PAKD
5 Cherry EEF
AGC
TROU
I've been able to go through manually and transpose the data for each row, which has resulted in over 33,000 rows. 我已经能够手动进行检查并转置每一行的数据,这导致了超过33,000行。 This was very time consuming and I don't doubt that I made some errors here and there so I wanted to explore a way to automate it.
这非常耗时,我毫不怀疑我在这里和那里都犯了一些错误,因此我想探索一种自动化的方法。
I've explored recording a macro by copying the row, pasting it at the bottom, copying the additional properties and transposing them below Property1 but every time I try to repeat this it only pastes to same row and never has the variable sizing of the row length. 我已经探索了通过复制行,将其粘贴在底部,复制其他属性并将其移到Property1下来记录宏的方法,但是每次我尝试重复此操作时,它只会粘贴到同一行,而没有行的可变大小长度。 I've commented it out in the macro where I was attempting to increment by 1 but it gave a 'type mismatch' error
我在试图将其递增1的宏中将其注释掉,但它给出了“类型不匹配”错误
Recorded macro: 录制的宏:
Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+Shift+A
'
Selection.Copy
ActiveWindow.ScrollRow = 9922
ActiveWindow.SmallScroll Down:=3
'Range("A9948").Value = Range("A9948").Value + 1
Range("A9948").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=6
Range("E9948:Z9948").Select
Application.CutCopyMode = False
Selection.Copy
Range("D9949").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
Any help would be appreciated. 任何帮助,将不胜感激。
Try this code. 试试这个代码。 The input range is the first column from Apple to Cherry.
输入范围是从Apple到Cherry的第一列。
Set Rng = Sheets("sheet1").Range("B2:B6") 'Input range of all fruits
Set Rng_output = Sheets("sheet2").Range("B2") 'Output range
For i = 1 To Rng.Cells.Count
Set rng_values = Range(Rng.Cells(i).Offset(0, 1), Rng.Cells(i).End(xlToRight)) 'For each fruit taking the values to the right which need to be transposed
If rng_values.Cells.Count < 16000 Then 'To ensure that it doesnt select till the right end of the sheet
For j = 1 To rng_values.Cells.Count
Rng_output.Value = Rng.Cells(i).Value
Rng_output.Offset(0, 1).Value = rng_values.Cells(j).Value
Set Rng_output = Rng_output.Offset(1, 0) 'Shifting the output row so that next value can be printed
Next j
End If
Next i
Create an excel file with the data as shown in the input and run the code stepwise to understand it 使用输入中显示的数据创建一个excel文件,并逐步运行代码以理解它
Is this the outcome you are after? 这是您追求的结果吗?
Option Explicit
Public Sub TransposeRows()
Dim i As Long, j As Long, k As Long, ur As Variant, tr As Variant
Dim thisVal As String, urMaxX As Long, urMaxY As Long, maxY As Long
With Sheet1
ur = .UsedRange
urMaxX = UBound(ur, 1)
urMaxY = UBound(ur, 2)
maxY = urMaxX * urMaxY
ReDim tr(2 To maxY, 1 To 3)
k = 2
For i = 2 To urMaxX
For j = 2 To urMaxY
thisVal = Trim(ur(i, j))
If Len(thisVal) > 0 Then
If j = 2 Then
tr(k, 1) = Trim(ur(i, 1))
tr(k, 2) = Trim(ur(i, 2))
tr(k, 3) = Trim(ur(i, 3))
j = j + 1
Else
tr(k, 3) = thisVal
End If
k = k + 1
Else
Exit For
End If
Next
Next
.UsedRange.Offset(1).Clear
.Range(.Cells(2, 1), .Cells(maxY, 3)) = tr
End With
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.