Преобразовать строку с столбцами данных в столбец с несколькими строками в Excel

Question

I 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

Я использовал ниже (основываясь на предложении Бена МакКормака, опубликованном 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

Вот действительно простое решение, предполагающее, что набор данных невелик.Он принимает входной диапазон в массив, преобразует его в массив результатов, а затем перемещает массив к указанной цели.Цель определяется верхней левой ячейкой.

Когда это возможно, этот подход на несколько порядков быстрее, чем работа непосредственно с ячейками на листах.

Функция тестирования внизу требует, чтобы вы поместили набор входных данных на лист InData, и для результатов был определен лист OutData, но ваши диапазоны ввода и вывода могут быть где угодно.

Answer 3

Вы можете использовать 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