Question

我在excel文件中有数据，格式如下：

+---------+----+----+----+----+----+----+
| Appname | R1 | R2 | R3 | R4 | R5 | R5 |
+---------+----+----+----+----+----+----+
|     123 |  1 |  2 |  3 |  5 |  6 |  9 |
|     234 |  3 |  5 |  6 |  7 |  8 |  9 |
|     345 |  2 |  6 |  7 |  8 |  9 |  0 |
+---------+----+----+----+----+----+----+

我需要R2到R5列下的所有值都显示在R1下。所以在输出文件中只有两列，即Appname和R1。

感谢任何想法或帮助。

Answer 1

试试这个......

以下代码假设您的原始数据位于名为Sheet1的工作表上。如果不是这样，请更改代码中的工作表名称。代码将创建一个名为＆＃34; Output＆＃34;使用所需格式的数据。

Sub ReArrangeData()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long, lc As Long, dlr As Long, i As Long

Application.ScreenUpdating = False

Set sws = Sheets("Sheet1")      'Sheet with raw data
lr = sws.UsedRange.Rows.Count
lc = sws.UsedRange.Columns.Count

On Error Resume Next
Set dws = Sheets("Output")
dws.Cells.Clear
On Error GoTo 0

If dws Is Nothing Then
    Sheets.Add(after:=sws).Name = "Output"
    Set dws = ActiveSheet
End If

dws.Range("A1:B1").Value = Array("AppName", "R1")
For i = 2 To lr
    dlr = dws.Cells(Rows.Count, "B").End(xlUp).Row + 1
    sws.Range("A" & i & ":B" & i).Copy dws.Range("A" & dlr)
    dlr = dws.Cells(Rows.Count, "B").End(xlUp).Row + 1
    sws.Range(sws.Cells(i, 3), sws.Cells(i, lc)).Copy
    dws.Range("B" & dlr).PasteSpecial xlPasteValues, Transpose:=True
Next i
On Error Resume Next
dlr = dws.Cells(Rows.Count, "B").End(xlUp).Row
dws.Range("A2:A" & dlr).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
dws.Range("A2:A" & dlr).Value = dws.Range("A2:A" & dlr).Value
dws.UsedRange.Columns.AutoFit
dws.Range("A1").CurrentRegion.Borders.Color = vbBlack
Application.ScreenUpdating = True
MsgBox "Task Completed!", vbInformation
End Sub

需要Excel支持

1 个答案: