使用 Excel VBA 复制部分行答案

【问题标题】：Duplicating partial rows using Excel VBA使用 Excel VBA 复制部分行
【发布时间】：2012-05-17 06:12:17
【问题描述】：

我有一些从其他地方导入的数据。如您所见，工作表主要可以通过将 F 和 G 中的数据向上移动一行来解决，问题出现在我需要在第 10 到 13 行的地方，这将是在数据向上移动之后一个将是 10 到 12 . 我需要将 9 到单元格 A 到 D 上的数据复制到 F 行的末尾。然后如果任何其他行有相同的“问题”，请继续向下执行相同的操作...

我希望我说清楚了，如果不是请询问，但是有人可以在这里帮助我吗？我考虑过使用直到最后副本的概念，但我可以看到它不起作用，因为并非所有单元都需要它......它只需要在机会出现时发生。

附上表格的链接，希望能澄清问题。

Link to Workbook here

【问题讨论】：

标签： excel vba

【解决方案1】：

我刚刚使用您提供的数据测试了这段代码。根据工作表中的数据，应该很好。当然，如果数据范围发生变化，可能需要稍作调整。

Sub clean_data()

Dim wks As Worksheet
Dim cel As Range

Set wks = ThisWorkbook.Sheets("Imported Data")

With wks

    'first bring columns F:G up to match their line
    For Each cel In Intersect(.UsedRange, .UsedRange.Offset(1), .Columns(6))

        If cel = vbNullString And cel.Offset(, -2) <> vbNullString Then
            .Range(cel.Offset(1), cel.Offset(1, 1)).Copy cel
            cel.Offset(1).EntireRow.Delete
        End If

    Next

    'now fil columns A:D to match PO Date and PO#
    For Each cel In Intersect(.UsedRange, .UsedRange.Offset(1), .Columns(1))

        If cel = vbNullString And cel.Offset(, 5) <> vbNullString Then
            .Range(cel.Offset(-1), cel.Offset(-1, 3)).Copy cel
        End If

    Next

End With

End Sub

【讨论】：

非常感谢他们工作得很好，你做的比我预期的要多得多。我喜欢这段代码的简洁性。
代码的简洁性很好。随着您在编码方面的成长，您将学习如何编写能够捕获许多常见错误或错误的简单代码。
我同意 100% 我只是希望更多的人会遵循这个思考过程。
俗话说“没有的东西传不来”

【解决方案2】：

我认为这会做你想要的：

Sub CleanUpImport()
    Dim LastCleanUpRow as Long
    Dim FirstSORow as Long
    Dim LastSORow
    Dim TitleRow As Long
    Dim ws As Worksheet

    Set ws = ThisWorkbook.Sheets(ActiveSheet.Name)
    LastCleanUpRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
    TitleRow = 1
    If Range("A1").Value = "" Then
        TitleRow = Range("A1").End(xlDown).Row
    End If

    ' Delete cells to line up columns F and G
    If Range("F3").Value = "" And Range("G3").Value = "" Then
        Range("F3:G3").Delete Shift:=xlUp
    End If

    ' Set rows for first SO
    LastSORow = LastCleanUpRow
    FirstSORow = LastSORow
    If Range("F" & LastSORow).Offset(-1).Value <> "" Then
        FirstSORow = Range("F" & LastCleanUpRow).End(xlUp).Row
    End If

    ' Copy SO header to any SOs that have multiple POs
    Do Until FirstSORow = TitleRow

        Range("A" & FirstSORow & ":D" & FirstSORow).Copy Range("A" & FirstSORow & ":D" & LastSORow)
        LastSORow = Range("F" & FirstSORow).End(xlUp).Row
        FirstSORow = LastSORow
        If Range("F" & LastSORow).Offset(-1).Value <> "" Then
            FirstSORow = Range("F" & LastSORow).End(xlUp).Row
            If FirstSORow = TitleRow Then FirstSORow = FirstSORow + 1
        End If
    Loop

End Sub

【讨论】：