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

我正在尝试编写一个macros，它将查看一个工作表中的数字用户input，并将在另一个工作表中复制某些次数。

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

工作表Sheet1

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 

这段代码做了类似的事情，但是为了多次复制而select的范围总是被设置为“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