将具有数据列的行转换为Excel中具有多行的列
我有数据行： –
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
我用下面的（根据本麦科马克的build议张贴在09年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
这是一个直接从工作表到工作表的方法。 如果数据集太大并且可用内存太小而不能使用数组，则这可能是必需的。 这可能会很慢。
它使用与reOrgV1相同的调用参数，以及几乎相同的逻辑。
它已更新，以添加“缺陷”的特性。 input如下所示：
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
您可以使用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
这是一个非常简单的解决scheme，假设数据集不是很大。 它将input范围转换为数组，将其转换为结果数组，然后将数组移动到指定的目标。 目标由左上angular的单元格定义。
在可能的情况下，这种方法比直接使用工作表上的单元格快几个数量级。
底部的testingfunction需要您在InData表上设置一个input，并为结果定义一个表OutData，但是您的input和输出范围可以在任意位置。
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