我有一个电子表格，其中包含一列信息，即：
VA221
VA222
VL911
VL911 S
VL911 M
VL911 L
VL911 XL
HF2301
HF2301 S
HF2301 M
HF2301 L
VS400
VS402
我需要根据下面的示例列中的项目将其移动到新工作表。
VA221 VA222 VL911 HF2301 VS400 VS402
VL911 S HF2301 S
VL911 M HF2301 M
VL911 L HF2301 L
VL911 XL
如果它只是一些我会手动做，但列将很长。如果有人能指出我正确的方向。
感谢您查看我的问题
瑞克
答案 0 :(得分：1)
这使用数组并且非常快：
Sub trnp()
Dim rngarr() As Variant
Dim oarr() As Variant
Dim rng As Range
Dim i As Long
Dim j As Long
Dim r As Long
Dim lg As Long
j = 1
r = 2
With ThisWorkbook.ActiveSheet
Set rng = .Range(.Cells(1, 1), Cells(.Rows.Count, 1).End(xlUp))
lg = .Evaluate("=LARGE(COUNTIF(" & rng.Address & ",""*"" & " & rng.Address & " & ""*""),1)")
rngarr = rng.Value
ReDim oarr(1 To lg, 1 To 1)
oarr(1, 1) = rngarr(1, 1)
For i = 2 To UBound(rngarr, 1)
If InStr(rngarr(i, 1), Trim(Left(rngarr(i - 1, 1), 6))) > 0 Then
oarr(r, j) = rngarr(i, 1)
r = r + 1
Else
j = j + 1
r = 2
ReDim Preserve oarr(1 To lg, 1 To j)
oarr(1, j) = rngarr(i, 1)
End If
Next i
'paste back array starting in B1
.Range("B1").Resize(UBound(oarr, 1), UBound(oarr, 2)).Value = oarr
End With
End Sub
答案 1 :(得分：1)
这是另一个使用数组和用户定义的对象来表示每列的VBA宏。用户定义的对象包含一个Column Header项，然后是一个下面的项集合。它应该很快。它假设数据位置应该可以在宏的顶部轻松修改。
（将其重命名为cColHeaders）
Option Explicit
Private pColHeader As String
Private pColItem As String
Private pColItems As Collection
Private Sub Class_Initialize()
Set pColItems = New Collection
End Sub
Public Property Get ColHeader() As String
ColHeader = pColHeader
End Property
Public Property Let ColHeader(Value As String)
pColHeader = Value
End Property
Public Property Get ColItem() As String
ColItem = pColItem
End Property
Public Property Let ColItem(Value As String)
pColItem = Value
End Property
Public Property Get ColItems() As Collection
Set ColItems = pColItems
End Property
Function ADDColItem(Value As String)
ColItems.Add Value
End Function
Option Explicit
Sub OrganizeByColumn()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes() As Variant
Dim cCH As cColumnHeaders, colCH As Collection
Dim I As Long, J As Long
Dim lMaxItems As Long 'will be the maximum number of items in a column
Dim V As Variant
'set source and results worksheets, ranges
Set wsSrc = Worksheets("sheet2")
Set wsRes = Worksheets("sheet3")
Set rRes = wsRes.Cells(1, 1) 'start results in wsRes A1
'Get source data == assumes in Col A starting at A1
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'Collect and organize the data
Set colCH = New Collection
For I = 1 To UBound(vSrc, 1)
Set cCH = New cColumnHeaders
With cCH
.ColHeader = vSrc(I, 1)
V = Split(.ColHeader)
If UBound(V) = 0 Then
colCH.Add cCH, .ColHeader
Else
.ColItem = vSrc(I, 1)
.ADDColItem .ColItem
colCH(V(0)).ADDColItem (.ColItem)
J = colCH(V(0)).ColItems.Count
lMaxItems = IIf(lMaxItems > J, lMaxItems, J)
End If
End With
Next I
'Create and populate results array
ReDim vRes(0 To lMaxItems, 1 To colCH.Count)
For I = 1 To colCH.Count
With colCH(I)
vRes(0, I) = .ColHeader
For J = 1 To .ColItems.Count
vRes(J, I) = .ColItems(J)
Next J
End With
Next I
'resize results range
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
'write and format the results
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
答案 2 :(得分：0)
假设在有空格（适用时）之前值中的最大字符数为6，则可以在RTrim循环中使用Left和While的组合。见下文：
Sub test()
Range("A1").Select
While ActiveCell.Value <> ""
If RTrim(Left(ActiveCell.Value, 6)) = RTrim(Left(ActiveCell.Offset(1, 0).Value, 6)) Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Select
If ActiveCell.Offset(1, 0).Value = "" Then
ActiveCell.Cut
ActiveCell.Offset(0, 1).Select
Selection.End(xlUp).Select
ActiveSheet.Paste
Selection.End(xlUp).Select
Else
Range(Selection, Selection.End(xlDown)).Cut
ActiveCell.Offset(0, 1).Select
Selection.End(xlUp).Select
ActiveSheet.Paste
Selection.End(xlUp).Select
End If
End If
Wend
End Sub