复制单元格“n”次。 “n”是用户指定的

Question

我正在尝试编写一个宏，它将在一个工作表中查看数字用户输入，并将在另一个工作表中复制多次。

例如，我想复制公司名称和ID“n”次。 “n”在同一行的最后一列中指定。

Sheet 1中

company name | company ID | number of items purchased here
----------------------------------------------
blue company |  999       | 2
rose company |  444       | 1
gold company |  222       | 3

第2页

company name | company ID
---------------------------
blue company | 999
blue company | 999
rose company | 444
gold company | 222
gold company | 222
gold company | 222

这段代码做了类似的事情，但是为锄头多次选择的范围总是被设置为“C2”中的任何内容。

Sub rangecopy()
    Dim source As Worksheet
    Dim destination As Worksheet
    Dim i As Integer, n As Integer
    Dim intHowmany As Integer

    Set source = Sheets("Sheet1")
    Set destination = Sheets("Sheet3")
    n = Sheets("Sheet1").Range("c2") 'number of times to be copied

    Range("a2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, (Selection.Offset(0, 1))).Select

    Selection.Copy

    intHowmany = Selection.Rows.Count

    destination.Select
    Range("a2").Select

    For i = 1 To n
        ActiveSheet.Paste
        ActiveCell.Offset(intHowmany, 0).Select
    Next i
End Sub

Answer 1

不是很优雅，但工作正常，并且能够轻松改变。

Sub rangecopy()
    Dim source As Worksheet
    Dim destination As Worksheet
    Dim i As Integer, n As Integer
    Dim intHowmany As Integer

    Set source = Sheets("Sheet1")
    Set destination = Sheets("Sheet2")
    destination.Cells(1, 1).Value = "Company"
    destination.Cells(1, 2).Value = "ID"
    startRow = 2
    usedRowsSrc = source.UsedRange.Rows.Count
    For i = startRow To usedRowsSrc
      strCompany = source.Cells(i, 1).Value
      strID = source.Cells(i, 2).Value
      iTimes = source.Cells(i, 3).Value

      For j = 1 To iTimes
        usedRowsDest = destination.UsedRange.Rows.Count
        With destination
          .Cells(usedRowsDest + 1, 1).Value = strCompany
          .Cells(usedRowsDest + 1, 2).Value = strID
        End With
      Next

    Next

End Sub

Answer 2

您可以使用数组

快速完成

这假设您的标题位于第1行，数据位于A：C

列

Sub Update()
Dim X
Dim Y
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lngCnt As Long
Dim lngCnt2 As Long
Dim lngCnt3 As Long

Set ws = Sheets(1)
Set ws2 = Sheets(2)

X = ws.Range(ws.[a1], ws.Cells(Rows.Count, "C").End(xlUp))

ReDim Y(1 To 2, 1 To Application.Sum(ws.Range("B:B")) + 1)

Y(1, 1) = X(1, 1)
Y(2, 1) = X(1, 2)

lngCnt3 = 1

For lngCnt = 2 To UBound(X, 1)
    For lngCnt2 = 1 To X(lngCnt, 2)
        lngCnt3 = lngCnt3 + 1
        Y(1, lngCnt3) = X(lngCnt, 1)
        Y(2, lngCnt3) = X(lngCnt, 2)
    Next
Next

ws2.[a1].Resize(UBound(Y, 2), UBound(Y, 1)) = Application.Transpose(Y)

End Sub