将excel行的一部分转置到其他行VBA中自身的副本

Question

我需要将当前存储在excel单行中的年度费用数据转换为自身在多行中的复制版本。为了澄清我的意思，这里有一个例子

原始数据源返回:

Name    Title   Year1Expense Year2Expense Year3Expense Year4Expense  other1   other 2   etc
Bob     Tech       30,000       17,000      20,000       18,000

我需要数据看起来像这样

Name    Title   Year    Expense   other1   other2   etc
Bob     Tech     1       30,000
Bob     Tech     2       17,000
Bob     Tech     3       20,000
Bob     Tech     4       18,000

我有数千个名字，并且提取的数据几乎总是不同数量的名字，所以它也需要能够动态转换这些数据。有没有人使用VBA在Excel中做类似的事情?感谢您的回复

Answer 1

只需在原始数据源上创建一个按钮，并将其设置为单击时使用此宏。

Sub Transpose_Click()
Dim numberOfRows, numberOfColumns, numberOfYears, counter, nextRow As Integer, originalSheet As String
originalSheet = ActiveSheet.Name
nextRow = 2
numberOfColumns = Range("A1").End(xlToRight).Column
numberOfYears = 0
counter = 5
For i = 1 To numberOfColumns
    If LCase(Left(CStr(Cells(1, i).Value), 4)) = "year" Then
        numberOfYears = numberOfYears + 1
    End If
Next
numberOfRows = Range("A1").End(xlDown).Row
Dim wsSheet As Worksheet
On Error Resume Next
Set wsSheet = Sheets("TransposedData")
On Error GoTo 0
If Not wsSheet Is Nothing Then
MsgBox "Sheet already exists, overwriting"
Else
MsgBox "Creating new sheet"
Sheets.Add.Name = "TransposedData"
End If
With Sheets("TransposedData")
    .Cells.Delete
    .Range("A1").Value = "Name"
    .Range("B1").Value = "Title"
    .Range("C1").Value = "Year"
    .Range("D1").Value = "Expense"
    For i = numberOfYears + 3 To numberOfColumns
        .Cells(1, counter).Value = Sheets(originalSheet).Cells(1, i).Value
        counter = counter + 1
    Next
    For i = 2 To numberOfRows
        For j = 1 To numberOfYears
            .Cells(nextRow, 1).Value = Sheets(originalSheet).Cells(i, 1).Value
            .Cells(nextRow, 2).Value = Sheets(originalSheet).Cells(i, 2).Value
            .Cells(nextRow, 3).Value = j
            .Cells(nextRow, 4).Value = Sheets(originalSheet).Cells(i, 2 + j).Value
            For k = 1 To (numberOfColumns - 2 - numberOfYears)
                .Cells(nextRow, 4 + k).Value = Sheets(originalSheet).Cells(i, 2 + numberOfYears + k).Value
            Next
            nextRow = nextRow + 1
        Next
    Next
End With
End Sub