将excel中的数据从列移到基于列标准的行中
我有一个电子表格，有一列的信息，即：
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
如果只是几个我会手动，但列会很长。 如果任何人都可以指出我正确的方向。
感谢您看我的问题
干草堆
这使用数组，将会非常快：
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
这是另一个VBAmacros，它使用数组和用户定义的对象来表示每一列。 用户定义的对象包含一个列标题项目，然后是下面的项目集合。 这应该是相当快的。 它假定数据位置应该在macros的顶部很容易修改。
类模块
（将其重命名为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
假设在有空格之前（如果适用的话）的值为最大字符数为6，则可以在While循环中使用RTrim和Left的组合。 见下文：
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