根据特定列上的单元格值将多行添加到另一个工作表
Adding a number of rows to another worksheet based on cell value on a certain column
我是 VBA 的新手，但遇到过手动执行此操作非常乏味的情况，所以我开始学习。
我需要一个脚本，它可以在列中找到某些文本值，然后将一定数量的行和所有行值复制到另一个工作表中。第一行的完整行值，下一行的前 5 行。搜索的文本值例如是 "DOL-1" 或 "VFD".
经过大量的研究和反复试验，我设法拼凑了这个完成工作的脚本，但它显然写得不好而且没有优化。我已经尝试搜索类似的问题并尝试了他们的答案，但我无法做这个脚本的任何事情。
我想知道是否有更好的 and/or 更快的方法来实现与此脚本相同的功能？
Sub Add_Rows()
Dim wbC As Workbook
Dim wbP As Workbook
Dim wsC As Worksheet
Dim wsP As Worksheet
Dim cell As Range
Dim r As Integer
Dim dataTable As Range
r = 8
'rownumber
Set wbP = Application.Workbooks.Open("C:\Projects\Feed_list.xlsx")
Set wsP = wbP.Worksheets("Feed_list")
' set paste destination (these variables aren't really even used because I couldn't get them to work)
Set wbC = Application.Workbooks.Open("C:\Projects\Generated_list.xlsm")
Set wsC = wbC.Worksheets("GEN")
' set copy location (these variables aren't really even used because I couldn't get them to work)
Windows("Generated_list.xlsm").Activate
Application.ScreenUpdating = False
For Each cell In Range("AB2:AB5000")
If cell.Value = "DOL-1" Then
Debug.Print cell.Address
Windows("Generated_list.xlsm").Activate
Range(cell, cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
'Debug.Print r
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.Offset(-1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
'Rows(r).Select
Selection.Offset(-1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
If cell.Value = "VFD" Then
Debug.Print cell.Address
Windows("Generated_list.xlsm").Activate
Range(cell, cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
'Debug.Print r
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.Offset(-1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
'these if functions are repeated about 20 times with different text values and number of rows copied
Next
Application.ScreenUpdating = True
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
End Sub
我制作了小示例图片。 Generated_listlooks like this.（通知栏AB）
Feed_listlooks like this at first.
在 运行 脚本之后它应该 look like this.
Sub Main()
Call Add_Rows(8)
End Sub
Sub Add_Rows(whereToAdd As Long)
Dim wb_Feed As Workbook, wb_Gen As Workbook
Dim ws_Feed As Worksheet, ws_Gen As Worksheet
Dim lastRow As Long, lastCol As Long, i As Long, idxType As Long
Set wb_Feed = Workbooks.Open("C:\Projects\Feed_list.xlsx")
Set wb_Gen = Workbooks.Open("C:\Projects\Generated_list.xlsm")
Set ws_Feed = wb_Feed.Worksheets("Feed_List")
Set ws_Gen = wb_Gen.Worksheets("Generated_List")
' Find the last row and last column of the data in Generated List
' Assume that the first column does not contain any blank data in middle
lastRow = ws_Gen.Cells(ws_Gen.Rows.Count, "A").End(xlUp).Row
lastCol = ws_Gen.Cells(1, ws_Gen.Columns.Count).End(xlToLeft).Column ' First row is header
' Column AB is the last column
idxType = lastCol
With ws_Gen
For i = 2 To lastRow
If .Cells(i, idxType).Value = "VFD" Then
' Insert a row to Feed List
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy entire row
.Range(.Cells(i, 1), .Cells(i, lastCol)).Copy
' Paste
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Since VFD, insert extra 1 line according to your screenshot
whereToAdd = whereToAdd + 1
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy first 5 columns
.Range(.Cells(i, 1), .Cells(i, 5)).Copy
' Paste
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Update where to add next
whereToAdd = whereToAdd + 1
ElseIf .Cells(i, idxType).Value = "DOL-1" Then
' Insert a row to Feed List
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy entire row
.Range(.Cells(i, 1), .Cells(i, lastCol)).Copy
' Paste
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Since DOL-1 insert extra 3 lines according to your screenshot
whereToAdd = whereToAdd + 1
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy first 5 columns
.Range(.Cells(i, 1), .Cells(i, 5)).Copy
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
ws_Feed.Range("A" & whereToAdd + 1).PasteSpecial xlPasteAll
ws_Feed.Range("A" & whereToAdd + 2).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Update where to add next
whereToAdd = whereToAdd + 3
End If
Next i
End With
' You should close the workbook after you finish your job
End Sub
我是 VBA 的新手，但遇到过手动执行此操作非常乏味的情况，所以我开始学习。
我需要一个脚本，它可以在列中找到某些文本值，然后将一定数量的行和所有行值复制到另一个工作表中。第一行的完整行值，下一行的前 5 行。搜索的文本值例如是 "DOL-1" 或 "VFD".
经过大量的研究和反复试验，我设法拼凑了这个完成工作的脚本，但它显然写得不好而且没有优化。我已经尝试搜索类似的问题并尝试了他们的答案，但我无法做这个脚本的任何事情。
我想知道是否有更好的 and/or 更快的方法来实现与此脚本相同的功能？
Sub Add_Rows()
Dim wbC As Workbook
Dim wbP As Workbook
Dim wsC As Worksheet
Dim wsP As Worksheet
Dim cell As Range
Dim r As Integer
Dim dataTable As Range
r = 8
'rownumber
Set wbP = Application.Workbooks.Open("C:\Projects\Feed_list.xlsx")
Set wsP = wbP.Worksheets("Feed_list")
' set paste destination (these variables aren't really even used because I couldn't get them to work)
Set wbC = Application.Workbooks.Open("C:\Projects\Generated_list.xlsm")
Set wsC = wbC.Worksheets("GEN")
' set copy location (these variables aren't really even used because I couldn't get them to work)
Windows("Generated_list.xlsm").Activate
Application.ScreenUpdating = False
For Each cell In Range("AB2:AB5000")
If cell.Value = "DOL-1" Then
Debug.Print cell.Address
Windows("Generated_list.xlsm").Activate
Range(cell, cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
'Debug.Print r
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.Offset(-1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
'Rows(r).Select
Selection.Offset(-1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
If cell.Value = "VFD" Then
Debug.Print cell.Address
Windows("Generated_list.xlsm").Activate
Range(cell, cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
'Debug.Print r
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.Offset(-1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
'these if functions are repeated about 20 times with different text values and number of rows copied
Next
Application.ScreenUpdating = True
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
End Sub
我制作了小示例图片。 Generated_listlooks like this.（通知栏AB）
Feed_listlooks like this at first.
在 运行 脚本之后它应该 look like this.
Sub Main()
Call Add_Rows(8)
End Sub
Sub Add_Rows(whereToAdd As Long)
Dim wb_Feed As Workbook, wb_Gen As Workbook
Dim ws_Feed As Worksheet, ws_Gen As Worksheet
Dim lastRow As Long, lastCol As Long, i As Long, idxType As Long
Set wb_Feed = Workbooks.Open("C:\Projects\Feed_list.xlsx")
Set wb_Gen = Workbooks.Open("C:\Projects\Generated_list.xlsm")
Set ws_Feed = wb_Feed.Worksheets("Feed_List")
Set ws_Gen = wb_Gen.Worksheets("Generated_List")
' Find the last row and last column of the data in Generated List
' Assume that the first column does not contain any blank data in middle
lastRow = ws_Gen.Cells(ws_Gen.Rows.Count, "A").End(xlUp).Row
lastCol = ws_Gen.Cells(1, ws_Gen.Columns.Count).End(xlToLeft).Column ' First row is header
' Column AB is the last column
idxType = lastCol
With ws_Gen
For i = 2 To lastRow
If .Cells(i, idxType).Value = "VFD" Then
' Insert a row to Feed List
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy entire row
.Range(.Cells(i, 1), .Cells(i, lastCol)).Copy
' Paste
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Since VFD, insert extra 1 line according to your screenshot
whereToAdd = whereToAdd + 1
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy first 5 columns
.Range(.Cells(i, 1), .Cells(i, 5)).Copy
' Paste
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Update where to add next
whereToAdd = whereToAdd + 1
ElseIf .Cells(i, idxType).Value = "DOL-1" Then
' Insert a row to Feed List
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy entire row
.Range(.Cells(i, 1), .Cells(i, lastCol)).Copy
' Paste
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Since DOL-1 insert extra 3 lines according to your screenshot
whereToAdd = whereToAdd + 1
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy first 5 columns
.Range(.Cells(i, 1), .Cells(i, 5)).Copy
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
ws_Feed.Range("A" & whereToAdd + 1).PasteSpecial xlPasteAll
ws_Feed.Range("A" & whereToAdd + 2).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Update where to add next
whereToAdd = whereToAdd + 3
End If
Next i
End With
' You should close the workbook after you finish your job
End Sub