转换列在Excel

Question

多行数据的列到列

我HV行数据： -

TAG SKU SIZE GRADE LOCATION 
A001 123 12  A  X1 
A002 789 13  B  X3 
A003 456 15  C  X5 

我需要将其转换成： -

A001 123 SIZE 12 
A001 123 GRADE A 
A001 123 LOCATION X1 
A002 789 SIZE 13 
A002 789 GRADE B 
A002 789 LOCATION X3 
A003 456 SIZE 15 
A003 456 GRADE C 
A003 456 LOCATION X5 

我用下面的（根据本麦科马克的建议发布在11月23日'09），但它不会产生上述结果： -

Sub NormalizeSheet() 
Dim wsOriginal As Worksheet 
Dim wsNormalized As Worksheet 
Dim strKey As String 
Dim clnHeader As Collection 
Dim lngColumnCounter As Long 
Dim lngRowCounterOriginal As Long 
Dim lngRowCounterNormalized As Long 
Dim rngCurrent As Range 
Dim varColumn As Variant 

Set wsOriginal = ThisWorkbook.Worksheets("Original")  'This is the name of your original worksheet' 
Set wsNormalized = ThisWorkbook.Worksheets("Normalized") 'This is the name of the new worksheet' 
Set clnHeader = New Collection 

wsNormalized.Cells.ClearContents  'This deletes the contents of the destination worksheet' 

lngColumnCounter = 2 
lngRowCounterOriginal = 1 
Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter) 

' We'll loop through just the headers to get a collection of header names' 
Do Until IsEmpty(rngCurrent.Value) 
    clnHeader.Add rngCurrent.Value, CStr(lngColumnCounter) 
    lngColumnCounter = lngColumnCounter + 1 
    Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter) 
Loop 

'Here we'll reset our Row Counter and loop through the entire data set' 
lngRowCounterOriginal = 2 
lngRowCounterNormalized = 1 
lngColumnCounter = 1 

Do While Not IsEmpty(wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)) 

    Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter) 
    strKey = rngCurrent.Value ' Get the key value from the current cell' 
    lngColumnCounter = 2 

    'This next loop parses the denormalized values for each row' 
    Do While Not IsEmpty(wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)) 
     Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter) 

     'We're going to check to see if the current value' 
     'is equal to NULL. If it is, we won't add it to' 
     'the Normalized Table.' 
     If rngCurrent.Value = "NULL" Then 
      'Skip it' 
     Else 
      'Add this item to the normalized sheet' 
      wsNormalized.Range("A" & lngRowCounterNormalized).Value = strKey 
      wsNormalized.Range("B" & lngRowCounterNormalized).Value = clnHeader(CStr(lngColumnCounter)) 
      wsNormalized.Range("C" & lngRowCounterNormalized).Value = rngCurrent.Value 
      lngRowCounterNormalized = lngRowCounterNormalized + 1 
     End If 

     lngColumnCounter = lngColumnCounter + 1 
    Loop 
    lngRowCounterOriginal = lngRowCounterOriginal + 1 
    lngColumnCounter = 1 'We reset the column counter here because we're on a new row' 
Loop 



End Sub 

Answer 1

这是一个直接从工作表到工作表的方法。如果数据集太大而可用内存太小而不能使用数组，则可能需要这样做。它可能会很慢。

它使用与reOrgV1相同的调用参数，以及几乎相同的逻辑。

它已更新，将“缺陷”添加到本质。输入如下：

TAG  SKU SIZE GRADE LOCATION DEFECTS 
A001 123 12 A  X1  3 
A002 789 13 B  X3  5 
A003 456 15 C  X5  7 

这是代码。

Public Sub reOrgV2(inSource As Range, inTarget As Range) 
'' This version works directly on the worksheet 
'' and transfers the result directly to the target 
'' given as the top-left cell of the result. 

'' **** Changed to add "Defects" 
    Dim resNames() 
    Dim propNum As Integer 
    Dim srcRows As Integer 
    Dim resRows As Integer 
    Dim i As Integer 
    Dim j As Integer 
    Dim g As Integer 

    '' Shape the result 
    resNames = Array("Size", "Grade", "Location", "Defects") 
    propNum = 1 + UBound(resNames) 

    '' Row counts 
    srcRows = inSource.Rows.Count 
    resRows = srcRows * propNum 

    '' re-org and transfer source to result range 
    inTarget = inTarget.Resize(resRows, 4) 
    g = 1 
    For i = 1 To srcRows 
     For j = 0 To 3 
      inTarget.Item(g + j, 1) = inSource.Item(i, 1)  '' Tag 
      inTarget.Item(g + j, 2) = inSource.Item(i, 2)  '' SKU 
      inTarget.Item(g + j, 3) = resNames(j)    '' Property 
      inTarget.Item(g + j, 4) = inSource.Item(i, j + 3) '' Value 
     Next j 
     g = g + propNum 
    Next i 
End Sub 

这是修订后的调用采购更广泛的范围。

'' Call ReOrgV2 with input and output ranges 
Public Sub test4() 
    Dim i As Integer 
    i = Range("InData!A:A").Find("").Row - 2 
    reOrgV2 Range("InData!A2").Resize(i, 6), [OutData!A1] 
End Sub 

Answer 2

您可以使用ADO与Excel。粗略地：

Sub ColsToRows() 
Dim cn As Object 
Dim rs As Object 
Dim strFile As String 
Dim strCon As String 
Dim strSQL As String 
Dim s As String 
Dim i As Integer, j As Integer 

    ''This is not the best way to refer to the workbook 
    ''you want, but it is very convenient for notes 
    ''It is probably best to use the name of the workbook. 

    strFile = ActiveWorkbook.FullName 

    ''Note that if HDR=No, F1,F2 etc are used for column names, 
    ''if HDR=Yes, the names in the first row of the range 
    ''can be used. 
    ''This is the Jet 4 connection string, you can get more 
    ''here : http://www.connectionstrings.com/excel 

    strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Docs\TestBook.xls " _ 
      & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";" 

    ''Late binding, so no reference is needed 

    Set cn = CreateObject("ADODB.Connection") 
    Set rs = CreateObject("ADODB.Recordset") 


    cn.Open strCon 

    strSQL = "SELECT [TAG], [SKU], 'SIZE ' & [SIZE] As S, " _ 
      & "'GRADE ' & [GRADE] As G, 'LOCATION ' & [LOCATION] As L " _ 
      & "FROM [Sheet1$] a " _ 
      & "ORDER BY [Tag] " 

    rs.Open strSQL, cn, 3, 3 


    ''Pick a suitable empty worksheet for the results 

    With Worksheets("Sheet3") 

     j = 1 '' Row counter 

     Do While Not rs.EOF 
      For i = 2 To 4 
       .Cells(j, 1) = rs!Tag 
       .Cells(j, 2) = rs!SKU 
       .Cells(j, 3) = rs(i) 
       j = j + 1 
      Next 
      rs.MoveNext 
     Loop 
    End With 

    ''Tidy up 
    rs.Close 
    Set rs = Nothing 
    cn.Close 
    Set cn = Nothing 

End Sub 

Answer 3

这是一个非常简单的解决方案，假设数据集不是很大。它将输入范围转换为数组，将其转换为结果数组，然后将数组移动到指定的目标。目标由左上角的单元格定义。

如果可能，这种方法比直接使用工作表上的单元格快几个数量级。

底部的测试功能需要您在工作表InData上放置一个输入集，并为结果定义工作表OutData，但您的输入和输出范围可以在任意位置。

Option Explicit 

Public Sub reOrgV1(inSource As Range, inTarget As Range) 
'' This version uses VBA arrays to do the work. 
'' Takes a source range, reorganizes it to the target 
'' given as the top-left cell of the result. 

    Dim srcArray As Variant 
    Dim resArray As Variant 
    Dim resNames() 
    resNames = Array("SIZE", "GRADE", "LOCATION") 

    Dim srcRows As Integer 
    Dim resRows As Integer 
    Dim i As Integer 
    Dim j As Integer 
    Dim g As Integer 

    '' Move range into source array 
    srcArray = inSource.Value 
    srcRows = UBound(srcArray, 1) 
    resRows = srcRows * 3 

    ''Build result array 
    ReDim resArray(1 To resRows, 1 To 3) 

    '' transfer source to result array 
    g = 1 
    For i = 1 To srcRows 
     For j = 0 To 2 
      resArray(g + j, 1) = srcArray(i, 1) 
      resArray(g + j, 2) = srcArray(i, 2) 
      resArray(g + j, 3) = resNames(j) & " " & srcArray(i, j + 3) 
     Next j 
     g = g + 3 
    Next i 

    '' Move the results to the target range 
    inTarget.Resize(resRows, 3).Value = resArray 
End Sub 

Public Sub test1() 
    reOrgV1 Range("InData!A2:E4"), Range("OutData!A1") 
End Sub