excel - как продублировать каждую строку макросом

Question

У меня есть лист Excel с N + 1 строками, где столбец A имеет уникальный идентификатор N.

Мне нужно продублировать каждую строку, чтобы ниже строки N было три новых строки с уникальными идентификаторами N-b, N-c, N-d

например. примерные строки ввода:

id1    data here 
id2    data2 here 

например. образец вывода:

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

Answer 1

Вы можете попробовать что-то вроде этого

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

Answer 2

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

Answer 3

Я хотел просто дублировать строки без дефиса в конце каждого скопированного элемента данных, поэтому я пропустил последнюю строку в коде

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

Он отлично продублировал строки, спасибо.

Answer 4

Если мне нужно знать, как что-то сделать с помощью VBA, самый простой способ узнать это - сделать это вручную и записать мои действия в макросе. Обычно это простая процедура для редактирования макроса в соответствии с моими точными требованиями.