Fatal编程技术网
  • excel/
  • Excel 根据某列上的单元格值向另一工作表添加多行

Excel 根据某列上的单元格值向另一工作表添加多行

excel vba

Excel 根据某列上的单元格值向另一工作表添加多行,excel,vba,copy,rows,Excel,Vba,Copy,Rows,我是VBA新手，但有一种情况，手动操作会非常乏味，所以我开始学习 我需要一个脚本，它可以在一列中找到特定的文本值，然后将包含所有行值的特定行数复制到另一个工作表中。第一行为整行值，下一行为前5行值。搜索的文本值例如为“DOL-1”或“VFD” 经过大量的研究和尝试和错误，我已经成功地拼凑了这个脚本来完成这项工作，但它显然写得很糟糕，而且没有得到优化。我试着搜索类似的问题，并尝试他们的答案，但我无法得到任何东西来做这个脚本 我想知道是否有更好和/或更快的方法来实现与此脚本相同的功能 Sub Add

我是VBA新手，但有一种情况，手动操作会非常乏味，所以我开始学习

我需要一个脚本，它可以在一列中找到特定的文本值，然后将包含所有行值的特定行数复制到另一个工作表中。第一行为整行值，下一行为前5行值。搜索的文本值例如为“DOL-1”或“VFD”

经过大量的研究和尝试和错误，我已经成功地拼凑了这个脚本来完成这项工作，但它显然写得很糟糕，而且没有得到优化。我试着搜索类似的问题，并尝试他们的答案，但我无法得到任何东西来做这个脚本

我想知道是否有更好和/或更快的方法来实现与此脚本相同的功能

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
我制作了一些小示例图片。生成的_列表（注意AB列）

提要列表

在运行脚本之后，如果您还没有阅读它，我会告诉您。您可能会从阅读中受益。我在设置ws\u Gen=wb\u Gen.Worksheets（“生成的\u列表”）时遇到一个错误。。运行时错误“9”。下标超出范围。能否检查工作簿中工作表的名称。对我来说，我把它命名为生成的列表，但对你来说可能不同，所以你应该根据你拥有的更改名称。我想在你的情况下，你应该把它改成“GEN”啊，当然可以。我改变了这一点，现在它似乎工作得很好。稍后我将不得不进行更大规模的测试，但我想我会继续，并将此标记为答案。非常感谢。 
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