0

他の場所からインポートされたデータがいくつかあります。ご覧のとおり、シートは主にFとGのデータを1行上に移動することで解決できます。問題は、データを上に移動した後の10行から13行に必要な場合に発生します。 。9からセルAからDのデータが行Fの終わりまでコピーされる場所に配置する必要があります。次に、他の行に同じ「問題」がある場合は、下に続けて同じことを行います。

はっきりしているといいのですが、質問してください。誰かがここで私を助けてくれますか？最後までのコピーの概念を使用することを考えましたが、すべてのセルがそれを必要としないために機能しないことがわかります...それは機会が生じたときにのみ発生する必要があります。

問題を明確にするために、シートにリンクを添付しました。

ここにワークブックへのリンク

4

2 に答える 2

2

提供されたデータを使用してこのコードをテストしました。ワークシートのデータに基づいて、良いはずです。もちろん、データスコープが変更された場合は、わずかな調整が必要になる場合があります。

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
于 2012-05-15T16:10:54.353 に答える
0

私はこれがあなたが望むことをするだろうと思います：

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
于 2012-05-15T16:12:59.617 に答える