我有数据行： -
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
我使用了下面的内容（根据Ben McCormack在2009年11月23日发布的建议），但它没有产生上述结果： -
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
答案 0 :(得分：1)
这是一种直接从工作表到工作表的方法。如果数据集太大且可用内存太小而无法使用数组，则可能需要这样做。它可能会很慢。
它使用与reOrgV1相同的调用参数，几乎相同的逻辑。
更新后，将“DEFECTS”添加到本地。输入如下：
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
答案 1 :(得分：0)
您可以在Excel中使用ADO。大致是：
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
答案 2 :(得分：0)
这是一个非常简单的解决方案，假设数据集不是很大。它将输入范围转换为数组，将其转换为结果数组，然后将数组移动到指定的目标。目标由左上角的单元格定义。
如果可能，这种方法比直接处理工作表上的单元格要快几个数量级。
底部的测试功能需要您将输入设置放在工作表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