Как скопировать строки x раз на основе значений ячеек на другой лист и создать новый столбец, заполненный определенным содержимым?

Question

Я очень плохо знаком с VBA и борюсь с чем-то, что мне не удается добиться успеха.

У меня есть несколько столбцов, некоторые из которых работают в парах: первый элемент пары представляетразмер, а второй соответствующее количество.Моя цель - скопировать на новый лист столько строк, сколько есть в каждом соответствующем количестве, за исключением других столбцов количества и размера, зная, что значение столбцов «размер» не всегда одинаково для данного столбца.Я хотел бы иметь возможность сообщать текущий размер в определенный столбец на целевом листе (см. Пример ниже)

Поскольку изображение часто говорит лучше слов, я бы хотел, чтобы оно работало следующим образом:

Вот моя попытка кода, но она копирует только одну строку за раз (которая не самая проблемная, я могу обработать, чтобы повторить ее несколько раз)раз :)), но размер уникального столбца на целевом листе не сообщается:

Public Sub CopyData()
Dim rngSinglecell As Range
Dim rngQuantityCells As Range
Dim intCount As Integer

Set rngQuantityCells = Range("C2", Range("C2").End(xlDown))

For Each rngSinglecell In rngQuantityCells
    If IsNumeric(rngSinglecell.Value) Then
        If rngSinglecell.Value > 0 Then
            For intCount = 1 To rngSinglecell.Value
                Range(rngSinglecell.Address).EntireRow.Copy Destination:=Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Next
        End If
    End If
Next
End Sub

Надеюсь, мое объяснение достаточно ясное.(и извините за мой возможный плохой английский, который не является моим родным языком!)

Answer 1

Попробуйте это:

Public Sub CopyData()
Dim rngSinglecell As Range
Dim rngQuantityCells As Range
Dim intCount As Integer
Dim ws1 As Worksheet
Dim name_ws As String
Dim lastRow As Long, lastRow2 As Long

name_ws = "Sheet1" '<--- put name of your main worksheet

Set ws1 = ThisWorkbook.Sheets(name_ws)
With ws1

    lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
    Set rngQuantityCells = .Range("C2:C" & lastRow)

    For Each rngSinglecell In rngQuantityCells
        If IsNumeric(rngSinglecell.Value) Then

            If rngSinglecell.Value > 0 Then
                For intCount = 1 To rngSinglecell.Value
                    lastRow2 = ThisWorkbook.Sheets("Feuil2").Cells(Rows.Count, 3).End(xlUp).Row + 1
                    .Rows(rngSinglecell.Row).EntireRow.Copy ThisWorkbook.Sheets("Feuil2").Rows(lastRow2)
                Next
            End If

        End If
    Next

End With

End Sub