根据单元格值复制行并粘贴 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

给你：

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