Excelmacros将特定的单元格从一行转置到另一列

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

在每种情况下，两个空行将图像名称与放置在图像本身上的不同注释区分开来。 下一个图像与最后一个注释由三个空行分开。 所有的注释都以它们的编号来表示，包括一个测量，它的单位和一个关于它是哪种测量的注释。 但是，这种configuration是不实际的。 如果以这种方式显示，pipe理数据会容易得多：

以“Annotation”，“Comment”，“Value”和“Unit”作为标题的表格的forms，以及在同一行中的注释的所有信息。 到目前为止，我试图手动调换数据，但是当涉及到许多图像时，这会花费太长时间。 我也尝试使用macroslogging器来自动执行这个过程，但是它不起作用，因为它在工作表中使用了固定位置。 而且，所有图像都不具有相同数量的注释。

任何人都可以帮我创build一个macros来做这样的事情吗？ 最近我开始涉足VBA代码，但是这是我的联盟。

Answer 1

这个macros除了logging之间的界限外，还有3行。 重点是logging应该以“图像名称”开头（检查不区分大小写）。 您可以稍后调整以符合要求。

 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 

UPDATE

这里是一个优化的版本没有curidx和代码删除图像logging之间的额外的行：

 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

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

 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。