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

Question

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

在每种情况下，两个空行将Image名称与放在Image本身上的不同注释分开。下一个Image与最后一个注释分开三个空行。 所有注释都由它们的编号引用，包括一个测量，它的单位和关于它是哪种测量的注释。但是，这种倾向是不实际的。如果数据显示如下，则管理数据要容易得多：

表格形式为＆＃34;注释＆＃34;，＆＃34;评论＆＃34;，＆＃34;价值＆＃34;和＆＃34;单位＆＃34;作为标题，包含有关同一行中注释的所有信息。到目前为止，我已经尝试手动转置数据，但是当涉及到许多图像时，这会花费太长时间。我还尝试使用宏录制器来自动执行该过程，但由于它在工作表中使用固定位置，因此无法工作。此外，所有图像都没有相同数量的注释。

有没有人可以帮我创建一个宏来做这样的事情？我最近开始涉足VBA代码，但这已经超出了我的联盟。

Answer 1

此宏将执行除记录之间的行之外的工作，将保留3行。重点是记录应该以＆＃34; Image Name＆＃34; （该检查不区分大小写）。您可以稍后调整它以符合要求。

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。