VBA基于每行的单元格内容将行复制到新工作表（包含示例）

所以我希望有一些帮助来自动化一个过程，否则会涉及复制和编辑大约10,000行。

这是有关位置数据的东西。 基本上，这些主行有很多，但是它们没有单独的行号。 我希望能够根据列N中的内容将这些行扩展为单独的单元号行。列N旨在遵循严格的格式，即每行都是逗号分隔的单元格列表。

以下是来自第一张表格的一个例子，每一行将会有什么需要扩展。 请注意， 列N是绿色的，并遵循一致的格式，这将是这些行将被展开多less次的决定因素。

下面是工作表2 ，以及我希望VBA从工作表1创build的内容。 您可以看到，每一行都是根据Sheet 1中 N列的内容展开的。

就像我说的，预计这将涉及到几千行创build。

Answer 1

Option Explicit Sub Tester() Dim sht1, sht2, rwSrc As Range, rwDest As Range, v, arr, n Set sht1 = ThisWorkbook.Sheets("Sheet1") Set sht2 = ThisWorkbook.Sheets("Sheet2") sht2.Range("A2:M2").Resize(3, 13).Value = sht1.Range("A2:M2").Value Set rwDest = sht2.Range("A2:M2") 'destination start row Set rwSrc = sht1.Range("A2:M2") 'source row Do While Application.CountA(rwSrc) > 0 v = rwSrc.EntireRow.Cells(1, "N").Value 'list of values If InStr(v, ",") > 0 Then 'list of values: split and count arr = Split(v, ",") n = UBound(arr) + 1 Else 'one or no value arr = Array(v) n = 1 End If 'duplicate source row as required rwDest.Resize(n, 13).Value = rwSrc.Value 'copy over the unit values rwDest.Cells(1, "G").Resize(n, 1).Value = Application.Transpose(arr) 'offset to next destination row Set rwDest = rwDest.Offset(n, 0) 'next source row Set rwSrc = rwSrc.Offset(1, 0) Loop End Sub 

Answer 2

这是在同一张工作表.​​..在执行此操作之前，请将值复制到“Sheet2”。 不知道效率，但。

  Public Sub Test() Dim lr As Long ' To store the last row of the data range Dim counter As Long Dim Str As String ' To store the string in column N lr = Range("N65536").End(xlUp).Row 'Getting the last row of the data For i = lr To 2 Step -1 Str = Range("N" & i).Value ' Getting the value from Column N counter = 1 For Each s In Split(Str, ",") If counter > 1 Then Range("A" & (i + counter - 1)).EntireRow.Insert ' Inserting rows for each value in column N Range("G" & (i + counter - 1)).Formula = s ' Updating the value in Column G Else Range("G" & i).Formula = s ' No need to insert a new row for first value End If counter = counter + 1 Next s Next i lr = Range("G65536").End(xlUp).Row ' Pulling down other values from the first value row other rows Range("A1:N" & lr).Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.FormulaR1C1 = "=R[-1]C" ' Pasting the data as Values to avoid future formula issues. Range("A1:N" & lr).Copy Range("A1:N" & lr).PasteSpecial xlPasteValues MsgBox "Done" End Sub