Question

我得到了以下代码，应该是

1）搜索我的单词，将包含该单词的整行复制并粘贴到新表中

2）在第1张之后搜索一个单词，然后在新表格中复制并粘贴1）内容旁边的整行。

有人可以看看，我实际上无法获得结果，我没有得到任何错误。所以我假设它是整个副本并粘贴到我的新工作表名称。但是我不是百分百肯定。

Sub stack()

    Dim OSheet As String
    Dim NSheet As String
    Dim i As Integer
    Dim LRow As Integer
    Dim NSLRow As Integer

    OSheet = "Sheet1" 'Old Sheet Name
    NSheet = "Sheet7" 'New Sheet Name

    LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet

    Sheets(OSheet).Activate

    For i = 2 To LRow
         'Finds last row in the New Sheet
        If Sheets(NSheet).Cells(2, 1) = "" Then
            NSLRow = 1
        Else
            NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).Row
        End If

         'If cell has "First Name then..."
      Dim StrX As String
    If InStr(LCase(Cells(i, 1)), LCase("stack:")) Then
        StrX = Range(Cells(NSLRow + 1, 1), Cells(NSLRow + 1, 6)).Address
        Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
    ElseIf InStr(LCase(Cells(i, 1)), LCase("overflow:")) Then
        StrX = Range(Cells(NSLRow + 1, 7), Cells(NSLRow + 1, 8)).Address
        Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
    End If
    Next i

End Sub

编辑，预期结果：

！http://i.imgur.com/69elWuB.jpg

编辑，用你们提到的一些修补程序更新了代码。

Sub stackv2()
     'added Sheets(OSheets)to Range Cells
    Dim OSheet As String
    Dim NSheet As String
    Dim i As Integer
    Dim LRow As Integer
    Dim NSLRow As Integer

    OSheet = "Sheet1" 'Old Sheet Name
    NSheet = "Sheet7" 'New Sheet Name

    LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet

    Sheets(OSheet).Activate

    For i = 2 To LRow
         'Finds last row in the New Sheet
        If Sheets(NSheet).Cells(2, 1) = "" Then
            NSLRow = 1
        Else
            NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).Row
        End If

         'If cell has "First Name then..."
      Dim StrX As String
    If InStr(LCase(Cells(i, 1)), LCase("first name")) Then
        StrX = Sheets(OSheet).Range(Sheets(OSheet).Cells(NSLRow + 1, 1), Sheets(OSheet).Cells(NSLRow + 1, 6)).Address
        Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
    ElseIf InStr(LCase(Cells(i, 1)), LCase("last name")) Then
        StrX = Sheets(OSheet).Range(Sheets(OSheet).Cells(NSLRow + 1, 7), Sheets(OSheet).Cells(NSLRow + 1, 8)).Address
        Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
    End If
    Next i

End Sub

Answer 1

这适用于您的示例：

    Sub stackv2()

    Dim OSheet As Worksheet
    Dim NSheet As Worksheet
    Dim i As long
    Dim LRow As long
    Dim NSLRow As Long
    Dim cpyClm As Long

    Set OSheet = Sheets("Sheet1") 'change to your Old Sheet Name
    Set NSheet = Sheets("Sheet7") 'change to your New Sheet Name
    cpyClm = 1 'change this to the number columns desired

    'Finds last row in the New Sheet
    NSLRow = NSheet.Cells(NSheet.Rows.Count, 1).End(xlUp).Row

    With OSheet
        LRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet

        For i = 2 To LRow

            'If cell has "First Name then..."

            If InStr(LCase(.Cells(i, 1)), LCase("first name")) Then
                NSLRow = NSLRow + 1 'moves to new row every time this is true.
                NSheet.Cells(NSLRow, 1).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
            ElseIf InStr(LCase(Cells(i, 1)), LCase("last name")) Then
                NSheet.Cells(NSLRow, 1 + cpyClm).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
            ElseIf InStr(LCase(Cells(i, 1)), LCase("middle name")) Then
                NSheet.Cells(NSLRow, 1 + (cpyClm * 2)).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
            End If
        Next i
    End With

End Sub

但是因为我们不知道您的真实数据是什么样的，所以我可以更改要复制的列数。此外，由于您的示例不包含A列，并且您的解释需要它，您需要将单元格中的列更改为1而不是2

如果这不起作用或帮助您弄清楚如何自行调整，则需要发布数据和所需输出的实际表示。

复制/粘贴结果

1 个答案: