Скопируйте строку и вставьте X количество раз в зависимости от значения ячейки

Question

У меня есть макрос, который должен скопировать строку и вставить ее (значения, а не формулы) x раз в зависимости от значения в столбце A (количество). Это нужно повторить для «бесконечного» количества строк. После этого необходимо удалить столбец А.

Есть похожие вопросы к этому, но ни один из них не работает для меня, мой макрос также должен удалить два листа и сохранить файл в формате CSV с заданным именем. У меня есть сохранить и дать имя на основе значений ячеек, а не копировать и вставлять.

---

Так что я использовал VBA только около двух недель, поэтому я изо всех сил: Я пробовал то и это, и я могу заставить странный код работать сам по себе, но никогда с остальным кодом.

---

Private Sub CommandButton1_Click()

Dim Path As String
Dim Filename1 As String
Dim Filename2 As String
Path = "C:\Users\BergA2\Desktop\CSV Usage Upload\ "

Filename1 = Range("B1")
Filename2 = Range("D1")

I imagine the code would go in here: values for quantity are taken from sheet1 and moved into sheet3 using a simple formula 

Sheets("Sheet2").Delete
Sheets("Sheet1").Delete

ActiveWorkbook.SaveAs Filename:=Path & Filename1 & "-" & Filename2 & ".csv", FileFormat:=xlCSV


End Sub

---

Ввод (более двух столбцов)

Quantity User   ... 
1        A      ...
3        B      ...
0        C      ...

Выход:

User    ...
A       ...
B       ...
B       ...
B       ...

Answer 1

Вот, пожалуйста:

Option Explicit

Sub copyBasedOnColumnA()
    Dim numberCopies As Long
    Dim currentRow As Long
    Dim j As Long

    Dim sht as Worksheet
    Set sht = Sheets("add sheet name")

    currentRow = 2

    Do While Not IsEmpty(sht.Cells(currentRow, 1))
        'determine how often to copy the current row
        numberCopies = sht.Cells(currentRow, 1)

        'copy that many times
        For j = 2 To numberCopies
            sht.Rows(currentRow).copy
            sht.Rows(currentRow).Insert Shift:=xlDown

            'increment the counter, otherwise you also copy all the rows just input
            currentRow = currentRow + 1
        Next j

        'move to next row
        currentRow = currentRow + 1
    Loop

    Application.CutCopyMode = False

    sht.Columns(1).Delete
End Sub

Я предполагаю, что вы не хотите копировать заголовок.Вы можете определить, с какой строки вы хотите начать, установив переменную currentRow.Также я предположил, что у вас нет ничего импортированного в столбце A.

Answer 2

Предположим, у вас есть заголовки в первом ряду.

Public Function ReturnCol(ByVal searchString As String) As Integer
Dim rg As Range
Application.ScreenUpdating = False
ActiveWorkbook.ActiveSheet.Rows("1:1").Select
Set rg = Selection.Find(What:=searchString, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True, SearchFormat:=False)

If rg Is Nothing Then
    ReturnCol = 0
    Exit Function
Else
    ReturnCol = rg.Column
End If

End Function
Sub collect()
Dim col_pos As Integer
Dim usedrows As Long

Dim i As Integer
Dim user As String
Dim quant As Integer

Dim counter As Long
' Assuming headers are in the first row

' Calculate until which point to loop
usedrows = Sheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row

' Find the positions of the headers (column numbers)
quant_col_pos = ReturnCol("Quantity")
user_col_pos = ReturnCol("User")


counter = 0
If quant_col_pos <> 0 Then
    For i = 2 To usedrows
        user = Cells(i, user_col_pos).Value
        quant = Cells(i, quant_col_pos).Value
        Sheets("Sheet2").Activate

        If i = 2 Then
            Cells(1, 1).Value = "User"
        End If
        ' starting filling values from the 2nd row but somewhere need to remember
        'which one was the last row used therefore counter is used

        For x = 2 + counter To 1 + quant + counter
            ' first column
            Cells(x, 1).Value = user
        Next x
        counter = quant + counter
        Sheets("Sheet1").Activate

    Next i

End If
End Sub