VBA方法excel基于值将单元格移动到其他行

我正在用excel中的VBA方法挣扎。 我有一个CSV，需要根据产品的类别进行编辑。

csv看起来像这样：

我想要达到的结果是这样的：

这是我写的方法。 我觉得我很接近，但是还没有达到预期的效果。

Sub test() 'c is a CELL or a range Dim c As Range 'for each CELL in this range For Each c In Range("A2", Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 1)) 'Als de cel leeg is en de volgende niet dan If c = "" And c.Offset(1, 0) <> "" Then 'verplaats inhoud lege cel naar 1 boven c.Offset(-1, 6) = c.Offset(0, 5) 'Verwijder rij c.EntireRow.Delete 'Als de cel leeg is en de volgende ook dan ElseIf c = "" And c.Offset(1, 0) = "" Then 'verplaats inhoud lege cel naar 1 boven If c.Offset(0, 5) <> "" Then c.Offset(-1, 6) = c.Offset(0, 5) 'Als inhoud ElseIf c.Offset(1, 5) <> "" Then c.Offset(-1, 7) = c.Offset(1, 5) Else c.EntireRow.Delete c.Offset(1,0).EntireRow.Delete End If End If Next End Sub 

CSV中有一些行是完全空的，所以这也需要考虑。

Answer 1

我会遍历行并检查每个条目下面的两行是否填充，然后将条目的值设置为最后填充的值。 然后，您可以拆分此值以将值放入多个列中。

提示：当循环遍历单元格和删除行时，您总是希望从底部开始并按照自己的方式到达顶部。

尝试这个：

 Sub test() Dim arr() as String Dim x As Long, i as long, lRow as long With ThisWorkbook.Sheets("SheetName") lRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Insert 2 columns to hold the extra information .Columns("E:F").Insert For x = lRow to 2 Step -1 'Delete rows that are completely blank If .Cells(x, "A").Value = "" And .Cells(x, "D").Value = "" Then .Cells(x, "A").EntireRow.Delete 'Find the next entry ElseIf .Cells(x, "A").Value <> "" Then 'Check if the 2nd row below the entry is populated If .Cells(x + 2, "A").Value = "" And .Cells(x + 2, "D").Value <> "" Then .Cells(x, "D").Value = .Cells(x + 2, "D").Value .Range(.Cells(x + 2, "D"), .Cells(x + 1, "D")).EntireRow.Delete 'Split the strings using the "/" character, if there is also a space you will need to use "/ " instead, then populate the inserted columns arr = Split(.Cells(x, "D").Value, "/") For i = 0 to UBound(arr) .Cells(x, 4 + i).Value = arr(i) Next i 'If the 2nd row isn't populated only take the row below ElseIf .Cells(x + 1, "A").Value = "" And .Cells(x + 1, "D").Value <> "" Then .Cells(x, "D").Value = .Cells(x + 1, "D").Value .Cells(x + 1, "D").EntireRow.Delete 'Split the strings using the "/" character, if there is also a space you will need to use "/ " instead, then populate the inserted columns arr = Split(.Cells(x, "D").Value, "/") For i = 0 to UBound(arr) .Cells(x, 4 + i).Value = arr(i) Next i End If End If Next x End With End Sub 

Answer 2

您可以移动最后2列，并使用文本到列来分割列：

 Sub test() ': Cells.Delete: [A1:F1,A3:F3] = [{1,2,3,"a/b/c",7,8}] ' used for testing Dim rng As Range Set rng = Sheet1.UsedRange ' set the range here rng.Columns("E:F").Cut rng.Resize(, 2).Insert xlToRight ' move the last 2 columns rng.Columns("D").TextToColumns OtherChar:="/" ' split the last column rng.SpecialCells(xlCellTypeConstants).EntireRow.Hidden = True ' hide non-empty rows rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete ' delete visible rows rng.EntireRow.Hidden = False ' un-hide the rows Set rng = rng.CurrentRegion rng.Resize(, 2).Cut ' move the 2 columns back to the end rng.Resize(, 2).Offset(, rng.Columns.Count).Insert xlToRight End Sub 

图像被挡在我现在的位置，所以列可能需要一些调整