将列转置为行，保持前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

然后将其格式化以提取上面第一张图片中所示的结果。

有什么方法可以得到我想要的结果吗？ 如果不先将两行格式化为列，这样做会更容易吗？

感谢您的时间。

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