Question

我正在使用以下脚本将数据复制到新工作表，它根据列数据将行复制一定次数。

我需要在脚本中添加一行：将值“ Word”添加到“ M”列和当前要复制的行中。

任何将其添加到脚本的帮助将不胜感激。

谢谢

Public Sub CopyData()
    ' This routing will copy rows based on the quantity to a new sheet.
    Dim rngSinglecell As Range
    Dim rngQuantityCells As Range
    Dim intCount As Integer

    ' Set this for the range where the Quantity column exists. This works only if there are no empty cells
    Set rngQuantityCells = Range("K2", Range("K2").End(xlDown))

    For Each rngSinglecell In rngQuantityCells
        ' Check if this cell actually contains a number
        If IsNumeric(rngSinglecell.Value) Then
            ' Check if the number is greater than 0
            If rngSinglecell.Value > 0 Then
                ' Copy this row as many times as .value
                For intCount = 1 To rngSinglecell.Value
                    ' Copy the row into the next emtpy row in sheet2


                    'Change EntireRow.Copy to a range in the row.
                    Range(rngSinglecell.Address).EntireRow.Copy Destination:=Sheets("Import").Range("A" & Rows.Count).End(xlUp).Offset(1)
                    ' The above line finds the next empty row.


                Next
            End If
        End If
    Next
End Sub

Answer 1

您可以：

使用SpecialCells()对象的Range方法遍历范围的数值
使用Resize()对象的Range属性来避免粘贴循环

如下：

Public Sub CopyData()
    ' This routing will copy rows based on the quantity to a new sheet.
    Dim rngSinglecell As Range
    Dim rngQuantityCells As Range
    Dim intCount As Long

    ' Set this for the range where the Quantity column exists. This works only if there are no empty cells
    Set rngQuantityCells = Range("K2", Range("K2").End(xlDown))
    If WorksheetFunction.Count(rngQuantityCells) = 0 Then Exit Sub ' do nothing if no numbers in wanted range

    For Each rngSinglecell In rngQuantityCells.SpecialCells(xlCellTypeConstants, xlNumbers) ' loop through numeric values of wanted range
        ' Check if the number is greater than 0
        If rngSinglecell.Value > 0 Then
            Range(rngSinglecell.Address).EntireRow.Copy Destination:=Sheets("Import").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(rngSinglecell.Value)
            Cells(rngSinglecell.Row, "M").Value = "Word" ' <-- added line
        End If
    Next
End Sub

复制行并添加值，VBA

1 个答案: