Excel VBAmacros将长行拆分为许多等长的行

我目前正在一个问题，我有一个Excel电子表格，我想使用VBAmacros。 以下3行中的每一行都是连续的。

Name of Data abc A1 B2 B4 C4 E2 F43 d4 V8 f9 k11 j20 … x cde A2 B3 B12 C6 E9 F34 d6 V4 f13 k111 j209 … x efg A3 B5 B7 C8 E11 F68 d19 V12 f91 k114 j2014 … x … Desired abc A1 B2 B4 C4 E2 F43 d4 V8 abc f9 k11 j20 … cde A2 B3 B12 C6 E9 F34 d6 V4 cde f13 k111 j209 … efg A3 B5 B7 C8 E11 F68 d19 V12 efg f91 k114 j2014 … 

我有每行的数据名称和一些行可以是长达数百列的数百个条目。 所以我想要做的是让我的行长停在8列宽。 我希望macros可以检查每一行，看看长度是否大于8，插入一个具有相同数据名称的行，然后粘贴下面的8列，从总列中减去它并粘贴下一行，直到它已经到达第一长排的末尾，并继续检查所有的行。 从本质上来说，它可以节省大量的时间，将8列的数据统计起来，剪切并粘贴到下面的插入行中，保留所有其他数据。 我是新来的，所以macros或VBA的帮助非常感谢。

谢谢，约翰

Answer 1

下面的macros将按照你的要求完成。 它有一些假设，我会留给你修复，如

• 数据在表1中
• 名称列始终是A ，所有数据列都从B开始
• 一切从单元格A1开始

这个macros将遍历每行，对于那些具有多于9个数据元素的行，它将创build一个新行，并使用前面的行Name和其余数据行填充它。 它将继续这样做，直到每行less于或等于8个数据元素为止。

由于你有很多行，所以closures屏幕更新是个好主意，比如在for循环之前Application.ScreenUpdating = False并在for循环之后重新打开。

 Public Sub SplitRows() Dim rowRange As Variant Dim colCount As Integer Dim lastColumn As Long Dim rowCount As Integer rowCount = Cells(Rows.Count, "A").End(xlUp).Row Dim i As Integer i = 1 Do While (i < rowCount) lastColumn = Sheet1.Cells(i, Columns.Count).End(xlToLeft).Column colCount = Sheet1.UsedRange.Columns.Count rowRange = Range(Cells(i, 2), Cells(i, colCount)) 'if the row has more than 9 values (name column + 8 data columns) If Not lastColumn <= 8 Then Dim x As Integer 'from column 2 (B, aka first data column) to last column For x = 2 To colCount - 1 'if data is not empty AND x mod 8 is 1 (meaning 8 goes into x enough times to have a remainder of 1) If Not IsEmpty(rowRange(1, x - 1)) And (x Mod 8) = 1 Then Cells(i, 1).Offset(1).EntireRow.Insert 'insert new row below current row rowCount = rowCount + 1 'update row count because we added a row Sheet1.Cells(i + 1, 1).Value = Sheet1.Cells(i, 1).Value 'set first column name Dim colsLeft As Integer For colsLeft = x To colCount - 1 'take data value from col 9 to end and populate newly created row Sheet1.Cells(i + 1, colsLeft - 7).Value = rowRange(1, colsLeft) Sheet1.Cells(i, colsLeft + 1).Value = "" 'set data value from col 9 on and set to empty Next Exit For 'exit loop, weve done all we need to and must now check the newly populated row End If Next End If i = i + 1 Loop End Sub 

这里是前后的结果：

之前

后

Answer 2

呃，我尝试了一下，但是我得去上class了。 也许这是一个有益的起点。

 Public Sub Test() Dim mastercell As Range Set mastercell = ActiveWorkbook.Worksheets(1).Cells(1, 1) Dim masterValue As String masterValue = mastercell.Value If GetCount(masterValue) > 8 Then Dim tempvalue As String tempvalue = masterValue Dim Rowcount As Integer Dim ColCount As Integer Rowcount = mastercell.Row ColCount = mastercell.Column + 1 Do While GetCount(tempvalue) > 8 Dim WriteValue As String WriteValue = GetFirstEight(tempvalue) ActiveWorkbook.Worksheets(1).Cells(Rowcount, ColCount).Value = WriteValue ColCount = ColCount + 1 tempvalue = Replace(tempvalue, WriteValue, 0, 1) Loop End If End Sub Private Function GetCount(str As String) As Integer Dim Splitter As String Splitter = " " Dim SplitArray As Variant SplitArray = Split(str) GetCount = UBound(SplitArray) End Function Private Function GetFirstEight(str As String) As String Dim i As Integer Dim NewString As String Dim SplitArray() As String SplitArray = Split(str) For i = 0 To 7 NewString = NewString & SplitArray(i) & " " Next GetFirstEight = NewString End Function