Excel宏将特定单元格从行转置到列

Question

我正在处理来自图像分析软件的数据，该软件通过以下方式导出数据：

在每种情况下，两个空行将图像名称与图像本身的不同注释分开。下一个图像与最后一个注释相隔三个空行。 所有注释都由它们的编号引用，包括测量、单位和关于它是哪种测量的注释。然而，这种配置并不实用。如果这样显示，管理数据会容易得多：

以表格的形式，以“Annotation”、“Comment”、“Value”和“Unit”作为标题，在同一行中包含有关注释的所有信息。到目前为止，我已经尝试手动转置数据，但是当涉及到许多图像时，这需要很长时间。我还尝试使用宏记录器来自动化该过程，但它不起作用，因为它使用工作表中的固定位置。此外，并非所有图像都具有相同数量的注释。

谁能帮我创建一个宏来做这样的事情？我最近开始涉足 VBA 代码，但这超出了我的范围。

Answer 1

这个宏会做除了记录之间的行之外的工作，将保留 3 行。要点是记录应该以“图像名称”开头（检查不区分大小写）。您可以稍后对其进行调整以符合要求。

Sub ReorderImageRecords()
Dim cnt As Long, curidx As Long

For i = 1 To ActiveSheet.UsedRange.Rows.Count
 cnt = 0
 If Left(LCase(Cells(i, 1)), 10) = "image name" Then
   Cells(i + 1, 1).EntireRow.Delete
   Cells(i + 1, 1).EntireRow.Delete
   curidx = i
   Cells(curidx + 1, 1) = "Annotation"
   Cells(curidx + 1, 2) = "Comment"
   Cells(curidx + 1, 3) = "Value"
   Cells(curidx + 1, 4) = "Unit"
   While Not IsEmpty(Cells(curidx + cnt + 2, 2))
     cnt = cnt + 1
     Cells(curidx + cnt + 1, 2) = Cells(curidx + cnt + 2, 3)
     Cells(curidx + cnt + 2, 2).EntireRow.Delete
   Wend
   i = i + cnt + 1
 End If
Next i

End Sub

更新

这是一个优化版本，没有curidx，并带有删除图像记录之间多余行的代码：

Sub ReorderImageRecords()
Dim cnt As Long, i As Long

For i = 1 To ActiveSheet.UsedRange.Rows.Count
 cnt = 0
 If i > 1 Then ' If it is not the 1st row
   If Application.CountA(Cells(i - 1, 1).EntireRow) = 0 Then
     Cells(i - 1, 1).EntireRow.Delete ' Delete if the whole preceding row is empty
   End If
   If Application.CountA(Cells(i - 1, 1).EntireRow) = 0 Then
     Cells(i - 1, 1).EntireRow.Delete ' Repeat row removal
   End If
 End If
 If Left(LCase(Cells(i, 1)), 10) = "image name" Then ' We found an image record start
   Cells(i + 1, 1).EntireRow.Delete ' We delete unnecessary blank rows
   Cells(i + 1, 1).EntireRow.Delete ' Repeat removal
   Cells(i + 1, 1) = "Annotation"   ' Insert headers
   Cells(i + 1, 2) = "Comment"
   Cells(i + 1, 3) = "Value"
   Cells(i + 1, 4) = "Unit"
   While Not IsEmpty(Cells(i + cnt + 2, 2)) ' If we are still within one and the same record
     cnt = cnt + 1
     Cells(i + cnt + 1, 2) = Cells(i + cnt + 2, 3) ' Copy comment
     Cells(i + cnt + 2, 2).EntireRow.Delete        ' Remove row with comment
   Wend
   i = i + cnt + 1 ' Increment row index to the current value
 End If
Next i

End Sub

Answer 2

我已经提到过我会发布一个可能的解决方案，所以就到这里（虽然有点晚了）。

Sub Test()
    Dim lr As Long, r As Range
    Application.ScreenUpdating = False
    With Sheet1 'source worksheet; change to suit
        lr = .Range("B" & .Rows.Count).End(xlUp).Row
        Set r = .Range("A1:D" & lr)
        r.Replace "Length", "": r.AutoFilter 1, "<>"
        r.SpecialCells(xlCellTypeVisible).Copy Sheet4.Range("A1")
        .AutoFilterMode = False
        r.AutoFilter 2, "<>"
        r.Offset(0, 2).Resize(, 1).SpecialCells(xlCellTypeVisible).Copy _
            Sheet4.Range("E1")
        .AutoFilterMode = False
    End With

    With Sheet4 'output worksheet; change to suit
        lr = .Range("A" & .Rows.Count).End(xlUp).Row
        .Range("B1:B" & lr).Copy: .Range("E1:E" & lr).PasteSpecial xlPasteValues, , True
        .Range("E1:E" & lr).Replace "Attribute Name", "Comment"
        .Range("E1:E" & lr).Cut .Range("B1")
        .Range("C1:C" & lr).AutoFilter 1, "<>"
        .Range("D2:D" & lr).SpecialCells(xlCellTypeVisible).Replace "", "Unit"
        .AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
End Sub

如果数据与您在上面发布的数据一致，这将起作用。
结果也将是这样的（图像名称之间没有空格）。
它还需要一个output worksheet（在上述情况下是Sheet4）。 HTH。