我有带有N + 1行的Excel工作表，其中A列具有唯一ID N.
我需要复制每一行，以便在第N行下面会有三个具有唯一ID的新行N-b，N-c，N-d
e.g。样本输入行：
id1 data here
id2 data2 here
e.g。样本输出：
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
答案 0 :(得分：5)
你可以试试这样的事情
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
答案 1 :(得分：0)
如果我需要知道如何使用VBA执行某些操作，最简单的方法是手动执行并在宏中记录我的操作。然后，根据我的精确要求编辑宏通常是一个简单的过程。
答案 2 :(得分：0)
我想在每个复制数据项的末尾复制没有连字符的行，所以我省略了代码中的最后一行
'copiedRow.Cells（1,1）= copiedRow.Cells（1,1）＆amp; “ - ”＆amp; Chr（97 + iCopy）
它完美地复制了行，谢谢。
答案 3 :(得分：-1)
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