圖片
你好，我想復制每封信的最后一行（在我的情況下為類別）。
以下是我的代碼。這是作業，但我相信有一種簡單的方法可以做到這一點。下一個問題：我有大約 80 個條目/類別，在這個示例代碼中只有 6 個類別（F1-F6）。所以如果我必須將代碼復制并粘貼到 F80，那真的會是一個很長的代碼，不是嗎？有沒有辦法簡化它？
代碼：
Sub Addrows()
Dim Fnd1 As Range, Finish
Count = Application.InputBox(Prompt:="How many row?", Default:=2)
F1:
Set Fnd1 = Range("O:O").Find("A", , , xlWhole, xlByRows, xlPrevious, False, ,
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert
Shift:=xlDown
Application.CutCopyMode = False
F2:
Set Fnd1 = Range("O:O").Find("B", , , xlWhole, xlByRows, xlPrevious, False, ,
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert
Shift:=xlDown
Application.CutCopyMode = False
F3:
Set Fnd1 = Range("O:O").Find("C", , , xlWhole, xlByRows, xlPrevious, False, ,
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert
Shift:=xlDown
Application.CutCopyMode = False
F4:
Set Fnd1 = Range("O:O").Find("D", , , xlWhole, xlByRows, xlPrevious, False, ,
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert
Shift:=xlDown
Application.CutCopyMode = False
F5:
Set Fnd1 = Range("O:O").Find("E", , , xlWhole, xlByRows, xlPrevious, False, ,
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert
Shift:=xlDown
Application.CutCopyMode = False
F6:
Set Fnd1 = Range("O:O").Find("F", , , xlWhole, xlByRows, xlPrevious, False, ,
False)
Fnd1.EntireRow.Select
Fnd1.EntireRow.Copy
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(Count, 0)).EntireRow.Insert
Shift:=xlDown
Application.CutCopyMode = False
MsgBox (Count & " was added")
End Sub
uj5u.com熱心網友回復：
請嘗試下一個版本。它首先確定唯一的類別（使用字典），然后使用它們在Count找到的最后一個類別行的下方插入行，然后將找到的行內容復制到插入的行中。它解決了“O：O”列中存在的盡可能多的類別：
Dim sh As Worksheet, lastRow As Long, rngOO As Range, Fnd1 As Range
Dim i As Long, Count As Long, arr, dict As Object
Count = 2 'it can be the result of an input in a InputBox
Set sh = ActiveSheet
lastRow = sh.Range("O" & sh.rows.Count).End(xlUp).row
Set rngOO = sh.Range("O3:O" & lastRow)
arr = rngOO.Value 'place the row in an array for faster iteration
Set dict = CreateObject("Scripting.Dictionary")
'Extract the unique categories:
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then dict(arr(i, 1)) = Empty
Next i
'finding the last unique categories and do copy its row of Count times:
For i = 0 To dict.Count - 1
Set Fnd1 = rngOO.Find(dict.Keys()(i), , , xlWhole, xlByRows, xlPrevious, False, , False)
Fnd1.EntireRow.copy
sh.Range(Fnd1.Offset(1, 0), Fnd1.Offset(Count, 0)).EntireRow.Insert Shift:=xlDown
Next i
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/413329.html
標籤：