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

Question

我正在使用以下列方式导出数据的图像分析软件中的数据：

在每种情况下，两个空行将图像名称与图像本身的不同注释分开。下一个图像与最后一个注释由三个空行分隔。所有注释均由其编号引用，并由测量、单位和关于测量类型的注释组成。然而，这种配置并不实用。如果数据显示成这样的话，管理起来会方便很多：

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

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

Answer 1

这个宏将完成除了记录之间的行之外的工作，将保留 3 行。要点是记录应以 "Image Name" 开头（检查不区分大小写）。您可以稍后调整它以符合要求。

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

我已经提到我会 post 一个可能的解决方案，所以这里开始（虽然有点晚）。

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

如果数据与您在上面 post 编辑的一致，这将起作用。
结果也将是这样的（图像名称之间没有 space）。
它还需要一个 output worksheet（在上面的例子中是 Sheet4）。 HTH.

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

Excel macro to transpose specific cells from row to column

excel

vba

transpose