如何使用Excel VBA分割和重构单元格
我目前使用的代码splits：
并将其更改为：
但是，这是我需要数据的格式：
这是我目前的代码的副本：
Sub SplitCells() Dim rColumn As Range Dim lFirstRow As Long Dim lLastRow As Long Dim lRow As Long Dim lLFs As Long Set rColumn = Columns("D") lFirstRow = 1 lLastRow = rColumn.Cells(Rows.Count).End(xlUp).Row For lRow = lLastRow To lFirstRow Step -1 lLFs = Len(rColumn.Cells(lRow)) - Len(Replace(rColumn.Cells(lRow), vbLf, "")) If lLFs > 0 Then rColumn.Cells(lRow + 1).Resize(lLFs).EntireRow.Insert xlShiftDown rColumn.Cells(lRow).Resize(lLFs + 1).Value = Application.Transpose(Split(rColumn.Cells(lRow), vbLf)) End If Next lRow End Sub 任何帮助/意见将不胜感激。
在代码的末尾调用ResizeToFitmacros
在当前代码中的End Sub之前添加ResizeToFit
即。
... Next lRow ResizeToFit ' or Call ResizeToFit End Sub ...
将这个代码添加到同一个模块作为一个新的子
Sub ResizeToFit() Application.ScreenUpdating = False Dim i As Long For i = Range("D" & Rows.Count).End(xlUp).Row To 1 Step -1 If IsEmpty(Range("D" & i)) Then Rows(i & ":" & i).Delete Else Range("E" & i) = Split(Range("D" & i), Chr(32))(1) Range("D" & i) = Split(Range("D" & i), Chr(32))(0) End If Next i For i = 1 To 5 If i <> 4 Then Cells(1, i).Resize(Range("D" & Rows.Count).End(xlUp).Row, 1).Value = Cells(1, i) End If Next Application.ScreenUpdating = True End Sub
采取这个
并运行我的代码生成
Sub SplitCells() Dim rColumn As Range Dim lFirstRow As Long Dim lLastRow As Long Dim lRow As Long Dim lLFs As Long Set rColumn = Columns("D") lFirstRow = 1 lLastRow = rColumn.Cells(Rows.Count).End(xlUp).Row For lRow = lLastRow To lFirstRow Step -1 lLFs = Len(rColumn.Cells(lRow)) - Len(Replace(rColumn.Cells(lRow), vbLf, "")) If lLFs > 0 Then rColumn.Cells(lRow + 1).Resize(lLFs).EntireRow.Insert xlShiftDown rColumn.Cells(lRow).Resize(lLFs + 1).Value = Application.Transpose(Split(rColumn.Cells(lRow), vbLf)) End If Dim curRow As Integer curRow = lRow + lLFs While curRow >= lRow If Application.CountA(Rows(curRow).EntireRow) = 0 Then Rows(curRow).Delete Else rColumn.Cells(curRow).Offset(0, 1).Value = Split(rColumn.Cells(curRow), " ")(1) rColumn.Cells(curRow).Value = Split(rColumn.Cells(curRow), " ")(0) rColumn.Cells(curRow).Offset(0, -3).Value = rColumn.Cells(lRow).Offset(0, -3).Value rColumn.Cells(curRow).Offset(0, -2).Value = rColumn.Cells(lRow).Offset(0, -2).Value rColumn.Cells(curRow).Offset(0, -1).Value = rColumn.Cells(lRow).Offset(0, -1).Value End If curRow = curRow - 1 Wend Next lRow End Sub
这只是从录制的macros，所以它需要清理。
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],LEN(RC[-1])-5)" Range("E1:E4").Select Selection.FillDown Range("F1").Select ActiveCell.FormulaR1C1 = "=RIGHT(RC[-2],4)" Range("F1:F4").Select Selection.FillDown Range("E1:F4").Select Selection.Copy Range("E1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("D:D").Select Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft
如果您对列D保持原样，并且分割部分位于右侧，则可能不需要剪切，粘贴和列删除。 在这种情况下
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],LEN(RC[-1])-5)" Range("E1:E4").Select Selection.FillDown Range("F1").Select ActiveCell.FormulaR1C1 = "=RIGHT(RC[-2],4)" Range("F1:F4").Select Selection.FillDown
对不起 – ActiveCell是E1。