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列中的导入。

复制行并粘贴X次取决于单元格值

2 个答案: