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
excel - how to duplicate each row with a macro
提问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
