Скопировать строку и добавить значение, VBA - PullRequest
Новая
       7

Скопировать строку и добавить значение, VBA

0 голосов
/ 10 октября 2018

Я использую следующий скрипт для копирования данных на новый лист, он копирует строку определенное количество раз, основываясь на данных столбцов.

Мне нужно добавить строку в скрипт, чтобы: добавить значение «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

1 Ответ

0 голосов
/ 10 октября 2018

Вы можете:

  • использовать 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
...