復制行並粘貼X次，具體取決於單元格值

Question

我有一個宏需要復制一行並粘貼它（值，而不是公式）x次取決於列A（數量）中的值。 這需要針對“無限”行重復。 完成此操作后，需要刪除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

假設您在第一行中有標題。

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

Answer 2

干得好：

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列中存儲任何導入內容。