Excel vba 宏根据单元格整数值多次复制行

Excel vba macro copy rows multiple times based on a cell integer value

提问by Dave

I am looking for a VBA Excel macro that copies complete rows to another work sheet. It would need to create additional duplicate copies of that row based on a cell integer value.

我正在寻找将完整行复制到另一个工作表的 VBA Excel 宏。它需要根据单元格整数值创建该行的额外副本。

This is helpful when using a mail merge where you want to create multiple copies of a document or label. I've found several answers which are close, but nothing that copies full rows

这在使用邮件合并创建文档或标签的多个副本时很有用。我找到了几个接近的答案，但没有复制完整行的答案

Input
col1 | col2 | col3 | col4
dogs | like | cats | 1
rats | like | nuts | 3
cats | chew | rats | 2

输入
col1 | col2 | col3 | col4
狗 | 喜欢 | 猫 | 1
老鼠 | 喜欢 | 坚果| 3
只猫 | 咀嚼| 老鼠| 高分辨率照片| CLIPARTO 2

Output col1 | col2 | col3 | col4
dogs | like | cats
rats | like | nuts
rats | like | nuts
rats | like | nuts
cats | chew | rats
cats | chew | rats

输出 col1 | col2 | col3 | col4
狗 | 喜欢 | 猫
老鼠|高分辨率照片| CLIPARTO 喜欢 | 坚果
老鼠|高分辨率照片| CLIPARTO 喜欢 | 坚果
老鼠|高分辨率照片| CLIPARTO 喜欢 | 坚果
猫| 高分辨率照片| CLIPARTO 咀嚼| 老鼠
猫| 高分辨率照片| CLIPARTO 咀嚼| 老鼠

Values in Output col4 could exist, doesn't matter for my case

输出 col4 中的值可能存在，对我来说无关紧要

回答by Francis Dean

Assuming the sheet with the data has the name 'Sheet1', the output sheet has the name 'Sheet2' and the amount of times to duplicate is located in row D - this code will work. You'll need to modify it to suit your needs first!

假设数据表的名称为“Sheet1”，输出表的名称为“Sheet2”，复制次数位于 D 行 - 此代码将起作用。您需要先修改它以满足您的需求！

Sub DuplicateRows()

Dim currentRow As Integer
Dim currentNewSheetRow As Integer: currentNewSheetRow = 1

For currentRow = 1 To 3 'The last row of your data

    Dim timesToDuplicate As Integer
    timesToDuplicate = CInt(Sheet1.Range("D" & currentRow).Value2)

    Dim i As Integer
    For i = 1 To timesToDuplicate

        Sheet2.Range("A" & currentNewSheetRow).Value2 = Sheet1.Range("A" & currentRow).Value2
        Sheet2.Range("B" & currentNewSheetRow).Value2 = Sheet1.Range("B" & currentRow).Value2
        Sheet2.Range("C" & currentNewSheetRow).Value2 = Sheet1.Range("C" & currentRow).Value2

        currentNewSheetRow = currentNewSheetRow + 1

    Next i

Next currentRow

End Sub

回答by Blogisch

I've made some changes and adjusted Francis Dean'sanswer:

我做了一些改变并调整了弗朗西斯·迪恩的回答：

• For those on Office 2013 (or 2010?), Excel needs to know explicitly that "Sheet1" is the name of a Sheet.
• Also I adapted the macro for more columns and rows. For example currentRowis Longand the last row being Integer+1.
• My integer value to determine duplicating is in "J".

• 对于 Office 2013（或 2010？）上的用户，Excel 需要明确知道“Sheet1”是工作表的名称。
• 我还为更多的列和行调整了宏。例如currentRow是Long，最后一行是Integer+1。
• 我确定复制的整数值在“J”中。

The macro is then:

那么宏是：

Sub DuplicateRows()
    Dim currentRow As Long
    Dim currentNewSheetRow As Long: currentNewSheetRow = 1

    For currentRow = 1 To 32768 'The last row of your data
    Dim timesToDuplicate As Integer
    timesToDuplicate = CInt(Worksheets("Sheet1").Range("J" & currentRow).Value)
    Dim i As Integer
    For i = 1 To timesToDuplicate
        Worksheets("Sheet2").Range("A" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("A" & currentRow).Value
        Worksheets("Sheet2").Range("B" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("B" & currentRow).Value
        Worksheets("Sheet2").Range("C" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("C" & currentRow).Value
        Worksheets("Sheet2").Range("D" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("D" & currentRow).Value
        Worksheets("Sheet2").Range("E" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("E" & currentRow).Value
        Worksheets("Sheet2").Range("F" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("F" & currentRow).Value
        Worksheets("Sheet2").Range("G" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("G" & currentRow).Value
        Worksheets("Sheet2").Range("H" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("H" & currentRow).Value
        Worksheets("Sheet2").Range("I" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("I" & currentRow).Value
        currentNewSheetRow = currentNewSheetRow + 1
    Next i
Next currentRow
End Sub

回答by epakai

I adapted Francis' answer to work from the current active spreadsheet and only on selected rows. My particular use case required changing the quantity to 1 for each duplication hence the "G" column being set to 1.

我改编了弗朗西斯的答案，以从当前活动的电子表格中工作，并且仅在选定的行上工作。我的特定用例需要将每次重复的数量更改为 1，因此“G”列设置为 1。

It still only works on a fixed set of columns.

它仍然只适用于一组固定的列。

Sub MultiplySelectedRows()
'store reference to active sheet
Dim Source As Worksheet
Set Source = ActiveWorkbook.ActiveSheet
'create new sheet for output
Dim Multiplied As Worksheet
Set Multiplied = Sheets.Add(After:=Worksheets(Worksheets.Count))
'switch back to original active sheet
Source.Activate
Dim rng As Range
Dim lRowSelected As Long
Dim duplicateCount As Integer
Dim newSheetRow As Integer
newSheetRow = 1
For Each rng In Selection.Rows
    lRowSelected = rng.Row
    'Column holding number of times to duplicate each row is specified in quotes
    duplicateCount = CInt(Source.Range("G" & lRowSelected).Value)
    Dim i As Integer
    For i = 1 To duplicateCount
        'one copy statement for each column to be copied
        Multiplied.Range("A" & newSheetRow).Value = Source.Range("A" & lRowSelected).Value
        Multiplied.Range("B" & newSheetRow).Value = Source.Range("B" & lRowSelected).Value
        Multiplied.Range("C" & newSheetRow).Value = Source.Range("C" & lRowSelected).Value
        Multiplied.Range("D" & newSheetRow).Value = Source.Range("D" & lRowSelected).Value
        Multiplied.Range("E" & newSheetRow).Value = Source.Range("E" & lRowSelected).Value
        Multiplied.Range("F" & newSheetRow).Value = Source.Range("F" & lRowSelected).Value
        'multiplier is replaced by 1 (16x1 instead of 1x16 lines)
        Multiplied.Range("G" & newSheetRow).Value = 1
        Multiplied.Range("H" & newSheetRow).Value = Source.Range("H" & lRowSelected).Value
        Multiplied.Range("I" & newSheetRow).Value = Source.Range("I" & lRowSelected).Value
        Multiplied.Range("J" & newSheetRow).Value = Source.Range("J" & lRowSelected).Value
        Multiplied.Range("K" & newSheetRow).Value = Source.Range("K" & lRowSelected).Value
        Multiplied.Range("L" & newSheetRow).Value = Source.Range("L" & lRowSelected).Value
        newSheetRow = newSheetRow + 1
    Next i
Next rng

End Sub

结束子