将数据行复制到新位置时，数据已正确复制，但是在数据行之间插入了空白行

Question

我是VBA的新手。

在工作簿中图纸的多个位置，我有4列数据。它们并不总是在同一列中，并且范围可以从不同的行开始。第一行始终包含相同的标题（ID，描述，时间，类别）。范围的第3列（时间）中的数据始终是数字。我要实现的目标是，将我选择的数据范围中的每一行复制到新位置，并重复第3列中指示的次数（将值“ 0”的行复制一次）。

我有一个输入框来选择要复制的范围，还有一个输入框来选择我要开始将数据复制到的单元格。

如果要复制到的目标从第1行开始，那么我编写的代码似乎可以正常工作。如果我的目标在其他任何行开始，则可以正确复制信息，但是在复制的数据的每一行之间都插入空白行。空白行的数量各不相同，并且似乎取决于分配来开始将输出数据复制到的行（即，如果在第2行至第1行之间输出空白，则在每个数据行之间插入空白行；如果输出在第3-2行开始在每个数据行之间插入空白行；如果输出从第4行开始-在数据行之间插入3个空白行等）。

通常，我的输出目标两侧的列中都会有数据，这些列中的数据也可以位于我的输出目标上方或下方的行中。 （即，如果我的输出目标是F4：I10，则可能在A1：D7和K9：L34中已经存在数据）这似乎不是我编写的代码中的问题，但我已经提到了它影响建议的解决方案。

我的数据和所需输出的示例是：

这是我一直在使用的代码。

Sub expandedcopy()

Dim source As Range
Dim destination As Range
Dim i As Integer, n As Integer
Dim ws As Worksheet
Dim lastblankrow As Long



Set source = Application.InputBox("Select the entire table (including headers) to extrapolate", Type:=8)

Set destination = Application.InputBox("Select the upper-left cell location to which your data will be coppied.  4 rows to the right are required", Type:=8)

destination.Offset(0, 0).Value = "ID"
destination.Offset(0, 1).Value = "Description"
destination.Offset(0, 2).Value = "Times"
destination.Offset(0, 3).Value = "Category"
StartRow = 2
usedRowsSrc = source.Rows.Count - 1

For i = StartRow To usedRowsSrc
  strID = source.Cells(i, 1).Value
  strDescription = source.Cells(i, 2).Value
  strTimes = source.Cells(i, 3).Value
  strCategory = source.Cells(i, 4).Value
  iTimes = source.Cells(i, 3).Value + 1

Set ws = destination.Worksheet

ws.Activate

  For j = 1 To iTimes
    lastblankrow = Cells(Rows.Count, destination.Column).End(xlUp).Row
    With destination
      .Offset(lastblankrow, 0).Value = strID
      .Offset(lastblankrow, 1).Value = strDescription
      .Offset(lastblankrow, 2).Value = strTimes
      .Offset(lastblankrow, 3).Value = strCategory
    End With
  Next

Next

End Sub

Answer 1

这是一种更简单的方法，其中将每一行完全复制所需的次数。

Sub expandedcopy()

Dim source As Range, destination As Range, i As Long, j As Long, n As Long

Set source = Application.InputBox("Select the entire table (including headers) to extrapolate", Type:=8)
Set destination = Application.InputBox("Select the upper-left cell location to which your data will be coppied.  4 rows to the right are required", Type:=8)

destination.Resize(, source.Columns.Count).Value = source.Rows(1).Value
j = 1

For i = 2 To source.Rows.Count
    n = source.Cells(i, 3).Value + Abs(source.Cells(i, 3).Value = 0)
    source.Cells(i, 1).Resize(, 4).Copy destination.Resize(n).Offset(j)
    j = j + n
Next i

End Sub