将列转置为行，使前3列保持相同

Question

我有以下格式的数据：

有没有办法将列转换为行，保持每行上的票号（A），日期（B）和发票（C），并根据分割每组数据的数量创建新行（列D- AI）？最多可以有10组数据，但每张发票下并不总是10组。

这是我希望实现的结果：

数据最初从2列导入，并使用以下宏转换为行（基于A列中的票证＃）：

Dim r       As Long
Dim c       As Long
r = 1
c = 2
For Each Cell In Rng
    ShNew.Cells(r, c).Value = Cell.Offset(0, 1).Value
    With Rng
        If Cell.Value <> Cell.Offset(1, 0).Value Then
            ShNew.Cells(r, 1).Value = Cell.Value
            r = r + 1
            c = 2
        Else
            c = c + 1
        End If
    End With
Next Cell

然后对其进行格式化以提取上面第一张图片中显示的结果。

有没有办法得到我想要的结果？如果没有最初将2行格式化为列，这样做会更容易吗？

感谢您的时间。

Answer 1

对我来说这是一个棘手的问题。

这就是我想出的。我不得不对你的数据做一些假设。我认为这种方法非常接近你所追求的目标。

输出数据 - 代码现在输出的内容

1111111111  2017-12-16 3:56 123456789   1   QCOM    2017-12-15  A   COMPLETE
2222222222  2017-12-16 3:56 987654321   1   MCD     2017-12-15  A   COMPLETE
3333333333  2017-12-16 3:56 123123123   1   QCOM    2017-12-15      
3333333333  2017-12-16 3:56 123123123   2   T       2017-12-15  A   COMPLETE
4444444444  2017-12-16 3:56 456456456   1   VZ      2017-12-15      
4444444444  2017-12-16 3:56 456456456   2   F       2017-12-15      
4444444444  2017-12-16 3:56 456456456   3   BO      2017-12-15  A   COMPLETE
5555555555  2017-12-16 3:56 789789789   1   T       2017-12-15      
5555555555  2017-12-16 3:56 789789789   2   CVX     2017-12-15      
5555555555  2017-12-16 3:56 789789789   3   COTY    2017-12-15      
5555555555  2017-12-16 3:56 789789789   4   FTS     2017-12-15      
5555555555  2017-12-16 3:56 789789789   5   IBM     2017-12-15      
5555555555  2017-12-16 3:56 789789789   6   MRK     2017-12-15      
5555555555  2017-12-16 3:56 789789789   7   PX      2017-12-15      
5555555555  2017-12-16 3:56 789789789   8   PG      2017-12-15      
5555555555  2017-12-16 3:56 789789789   9   TGT     2017-12-15      
5555555555  2017-12-16 3:56 789789789   10  F       2017-12-15  COMPLETE    

您可以注意到最后一个条目与您想要的数据集不完全匹配。这是预期的入场券吗？根据下面代码中的规则设置，此条目似乎与其他条目不同。话虽如此，添加一个特殊情况应该不会太费力，所以我想我会分享我想出的方法。

您需要创建一个名为Output的工作表，以便按原样工作。我正在输出结果，如输出数据部分所示。

码

Option Explicit

Public Sub Format_Data()
    On Error GoTo ErrorHandler:

    Dim inputSheet          As Worksheet
    Dim outputSheet         As Worksheet
    Dim lastRow             As Long
    Dim lastColumn          As Integer
    Dim rowCounter          As Long
    Dim outputArray()       As Variant
    Dim newItemCounter      As Long
    Dim colCounter          As Integer
    Const stepSize As Byte = 3

    Set inputSheet = ThisWorkbook.Sheets("Formatted")
    Set outputSheet = ThisWorkbook.Sheets("Output")

    lastRow = inputSheet.Cells(inputSheet.Rows.Count, "A").End(xlUp).Row
    If lastRow = 0 Then Err.Raise "1234", , "No Data in inputSheet!"

    'Make lots of room to add records
    ReDim outputArray(0 To 7, 0 To 10000)

    For rowCounter = 1 To lastRow

        With inputSheet

            'get the last column
            lastColumn = GetLastColumn(inputSheet, rowCounter)

            'In this condition there is only one entry
            If lastColumn = 8 Then
                outputArray(0, newItemCounter) = .Range("A" & rowCounter).Value
                outputArray(1, newItemCounter) = .Range("B" & rowCounter).Value
                outputArray(2, newItemCounter) = .Range("C" & rowCounter).Value
                outputArray(3, newItemCounter) = .Range("D" & rowCounter).Value
                outputArray(4, newItemCounter) = .Range("E" & rowCounter).Value
                outputArray(5, newItemCounter) = .Range("F" & rowCounter).Value
                outputArray(6, newItemCounter) = .Range("G" & rowCounter).Value
                outputArray(7, newItemCounter) = .Range("H" & rowCounter).Value
                newItemCounter = newItemCounter + 1

            ElseIf lastColumn > 8 Then

                For colCounter = 4 To lastColumn Step stepSize
                    'Make sure the value isn't null and the cell is numeric. This
                    'is the autonumber in columns
                    If Not .Cells(rowCounter, colCounter).Value = vbNullString _
                    And IsNumeric(.Cells(rowCounter, colCounter).Value) Then

                        outputArray(0, newItemCounter) = .Range("A" & rowCounter).Value
                        outputArray(1, newItemCounter) = .Range("B" & rowCounter).Value
                        outputArray(2, newItemCounter) = .Range("C" & rowCounter).Value
                        outputArray(3, newItemCounter) = .Cells(rowCounter, colCounter).Value
                        outputArray(4, newItemCounter) = .Cells(rowCounter, colCounter + 1).Value
                        outputArray(5, newItemCounter) = .Cells(rowCounter, colCounter + 2).Value

                        'Add additional fields if needed...this is seemingly indicated
                        'by a non numeric column
                        If Not IsNumeric(.Cells(rowCounter, colCounter + stepSize).Value) Then
                            outputArray(6, newItemCounter) = .Cells(rowCounter, colCounter + 3).Value
                            outputArray(7, newItemCounter) = .Cells(rowCounter, colCounter + 4).Value
                        End If

                        'keep track of where we are in the array
                        newItemCounter = newItemCounter + 1
                    End If
                Next

            Else
                'What happens when data isn't correct format?
                'add this exception here!
            End If

        End With

    Next

    'Resize the array and output
    ReDim Preserve outputArray(0 To 7, 0 To newItemCounter)
    outputSheet.Range("A1:H" & newItemCounter).Value = WorksheetFunction.Transpose(outputArray)

CleanExit:
    Exit Sub

ErrorHandler:
    Select Case Err.Number
        Case 1234
            Debug.Print Err.Description
    End Select

    Resume CleanExit
End Sub

'Helper function to get the last Contiguous column with data
'from left to right
Private Function GetLastColumn(currentSheet As Worksheet, rowCounter As Long)
    Dim colNumber As Integer

    For colNumber = 1 To 5000
        If currentSheet.Cells(rowCounter, colNumber).Value = vbNullString Then Exit For
    Next

    GetLastColumn = colNumber - 1
End Function