vba excel - 如何用宏复制每一行

声明:本页面是StackOverFlow热门问题的中英对照翻译,遵循CC BY-SA 4.0协议,如果您需要使用它,必须同样遵循CC BY-SA许可,注明原文地址和作者信息,同时你必须将它归于原作者(不是我):StackOverFlow 原文地址: http://stackoverflow.com/questions/2108632/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me): StackOverFlow

提示:将鼠标放在中文语句上可以显示对应的英文。显示中英文
时间:2020-09-11 11:15:36  来源:igfitidea点击:

excel - how to duplicate each row with a macro

excelvba

提问by Tom

I have excel sheet with N+1 rows where Column A has unique id N.

我有 N+1 行的 Excel 工作表,其中 A 列具有唯一的 id N。

I need to duplicate each row so that below a row N there will be three new rows with unique-ids N-b, N-c, N-d

我需要复制每一行,以便在第 N 行下面会有三个具有唯一 ID Nb、Nc、Nd 的新行

e.g. sample input rows:

例如示例输入行:

id1    data here 
id2    data2 here 

e.g. sample output:

例如样本输出:

id1    data here 
id1-b  data here 
id1-c data here
id1-d data here
id2    data2 here 
id2-b  data2 here 
id2-c data2 here
id2-d data2 here

回答by Adriaan Stander

You could try something like this

你可以试试这样的

Sub Macro1()
Dim sheet As Worksheet
Dim usedRange As Range

    Set sheet = ActiveSheet
    Set usedRange = sheet.usedRange

Dim i As Integer

    For i = 1 To usedRange.Rows.Count
        Dim row As Range
        Set row = usedRange.Rows(((i - 1) * 4) + 1)

        Dim iCopy As Integer

        For iCopy = 1 To 3
            row.Copy
            Dim insertRow As Range
            Set insertRow = usedRange.Rows(((i - 1) * 4) + 1 + iCopy)
            insertRow.insert xlDown
            Dim copiedRow As Range
            Set copiedRow = usedRange.Rows(((i - 1) * 4) + 1 + iCopy)
            copiedRow.Cells(1, 1) = copiedRow.Cells(1, 1) & "-" & Chr(97 + iCopy)

        Next iCopy
    Next i
End Sub

回答by Mick

If I need to know how to do something using VBA, the easiest way to find out is to do it manually and record my actions in a macro. It is then usually a simple procedure to edit the macro to my precise requirements.

如果我需要知道如何使用 VBA 做某事,最简单的找出方法是手动完成并在宏中记录我的操作。然后通常是一个简单的过程来编辑宏以满足我的精确要求。

回答by user2533460

I wanted to just duplicate the rows without the hyphen at the end of each copied data item so I omitted the last line from the code

我只想复制每个复制数据项末尾没有连字符的行,所以我省略了代码的最后一行

'copiedRow.Cells(1, 1) = copiedRow.Cells(1, 1) & "-" & Chr(97 + iCopy)

'copiedRow.Cells(1, 1) = CopyRow.Cells(1, 1) & "-" & Chr(97 + iCopy)

It duplicated the rows perfectly, thank you.

它完美地复制了行,谢谢。

回答by Yashwant Nandanwar

Sub Macro4()
'
' Macro4 Macro
'

'
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim s3 As Worksheet
Dim rng1 As Range
Set sheet1 = Sheets("Sheet1")
Set sheet2 = Sheets("Sheet2")

Dim empRange As Range

sheet1.Activate
Dim lastRow As Double
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For Each b In Range("A1:I" & lastRow).Rows
    Range("I" & b.Row).FormulaR1C1 = "=COUNT(RC[-4]:RC[-2])"
Next

Range("A1:I" & lastRow).AutoFilter Field:=9, Criteria1:="=2", _
        Operator:=xlOr, Criteria2:="=3"


Set rng1 = sheet1.Range(sheet1.[a2], sheet1.Cells(Rows.Count, "A").End(xlUp))

rng1.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select

Set A = Selection


Dim sheet2_last_row As Long
Dim empRecordCount As Long

For Each b In A.Rows
    sheet1.Activate
    courseKey = sheet1.Cells(b.Row, 1).Value
    catA = Cells(b.Row, 5).Value
    catB = Cells(b.Row, 6).Value
    catC = Cells(b.Row, 7).Value
    MsgBox courseKey & "-" & catA & "-" & catB & "-" & catC

    'apply auto filter on sheet 2 by course key
    sheet2.Activate
    Range("a1").Select
    Selection.AutoFilter Field:=2, Criteria1:=courseKey

    ActiveCell.Offset(1, 0).Cells.Select

    MsgBox "1"

    empRecordCount = Selection.SpecialCells(xlCellTypeVisible).Rows.Count
    'if found,
    If empRecordCount > 0 Then
        MsgBox "records found"

    'Check whether its first non empty category
        isFirstCategory = True

        Set empRange = sheet2.Range(Selection.Cells, sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp))
        empRange.Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Set empRecord = Selection

        Set s3 = Sheets("Sheet3")
        s3.Activate
        s3.Cells.ClearContents
        empRecord.Copy Destination:=s3.Cells(1, "A")

        MsgBox "2"

        Set s3_range = s3.Cells(1, "A")
        s3_range.Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Set s3_records = Selection

        MsgBox "3"

    'check whether catA is blank then set value in category column
        If catA <> "" Then
            sheet2.Activate
    Range("a1").Select
    Selection.AutoFilter Field:=2, Criteria1:=courseKey
            MsgBox "111"
            Set empRange = sheet2.Range(Selection.Cells, sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp))
            empRange.Select
            Range(Selection, Selection.End(xlToRight)).Select
            Range(Selection, Selection.End(xlDown)).Select
            MsgBox "2222"
            Set empRecord = Selection
            For Each e In empRecord.Rows
                sheet2.Activate
                sheet2.Cells(e.Row, 4).Value = "A"
                sheet2.Cells(e.Row, 5).Value = catA
            Next
            isFirstCategory = False
        End If
    'check catB is not blank. copy searched row rom shee 2 and insert it below change category column with Cat B
        If catB <> "" Then
            If isFirstCategory Then
                sheet2.Activate
                Set empRecord = Selection
                For Each e In empRecord.Rows
                    sheet2.Activate
                    sheet2.Cells(e.Row, 4).Value = "B"
                    sheet2.Cells(e.Row, 5).Value = catB
                Next
            Else
                s3.Activate
                If empRecordCount > 1 Then
                    Set s3_range = s3.Cells(1, "A")
                    s3_range.Select
                    Range(Selection, Selection.End(xlToRight)).Select
                    Range(Selection, Selection.End(xlDown)).Select
                    Set s3_records = Selection
                    For Each e In s3_records.Rows
                        s3.Cells(e.Row, 4).Value = "B"
                        s3.Cells(e.Row, 5).Value = catB
                    Next
                Else
                    s3.Cells(1, 4).Value = "B"
                    s3.Cells(1, 5).Value = catB
                End If

                sheet2.Activate
                sheet2.Cells(1, "A").Select
                Selection.AutoFilter
                MsgBox "4"
                sheet2_last_row = sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp).Row
                s3_records.Copy Destination:=sheet2.Cells(sheet2_last_row + 1, "A")

            End If
        End If
    'check catC is not blank. copy searched row rom shee 2 and insert it below change category column with Cat C
        If catC <> "" Then
            If isFirstCategory Then
                sheet2.Activate
                Set empRecord = Selection
                For Each e In empRecord.Rows
                    sheet2.Activate
                    sheet2.Cells(e.Row, 4).Value = "C"
                    sheet2.Cells(e.Row, 5).Value = catC
                Next
            Else
                s3.Activate
                If empRecordCount > 1 Then
                    Set s3_range = s3.Cells(1, "A")
                    s3_range.Select
                    Range(Selection, Selection.End(xlToRight)).Select
                    Range(Selection, Selection.End(xlDown)).Select
                    Set s3_records = Selection
                    For Each e In s3_records.Rows
                        s3.Cells(e.Row, 4).Value = "C"
                        s3.Cells(e.Row, 5).Value = catC
                    Next
                Else
                    s3.Cells(1, 4).Value = "C"
                    s3.Cells(1, 5).Value = catC
                End If

                sheet2.Activate
                sheet2.Cells(1, "A").Select
                Selection.AutoFilter
                MsgBox "5"
                sheet2_last_row = sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp).Row
                s3_records.Copy Destination:=sheet2.Cells(sheet2_last_row + 1, "A")

            End If
        End If


    End If

    s3.Activate
    s3.Cells.ClearContents

Next

sheet1.Activate
sheet1.Cells.Select
Selection.AutoFilter

sheet2.Activate
sheet2.Cells.Select
Selection.AutoFilter

End Sub