-1

次の点についてサポートが必要です。

列 G のデータに対して範囲 A9 - A32 をフィルター処理する必要があります。次に、データをコピーする必要がありますが、列 A - E & G のみをシート 2 にコピーします。次に、フィルター処理されたデータを削除し、フィルター処理されていないビューに戻ります。

私は成功せずに次のことを試しました：

Dim shSrc As Worksheet
Dim shDst As Worksheet
Dim rSrc As range
Dim rDst As range
Dim range
Dim numCol As Long ' number of columns to copy

On Error GoTo EH

range = ("A:E,G:G")

' select source and dest sheets
Set shSrc = ActiveWorkbook.Worksheets("Active Snag List")
Set shDst = ActiveWorkbook.Worksheets("Snag History")

' Select initial rows
Set rSrc = shSrc.Cells(9, 7)
Set rDst = shDst.Cells(2, 1)

' loop over source
Do While rSrc <> ""
    ' Test Source row, Qty = 0 and Name is not blank
    With rSrc
        If .Offset(0, 2) = 0 And .Value <> "" Then
            'Copy
            .Resize(1, range).Copy rDst.Resize(1, range)
            Set rDst = rDst.Offset(1, 0)
        End If
    End With
    Set rSrc = rSrc.Offset(1, 0)
Loop
Exit Sub
EH:
MsgBox "Error " & Err.Description

前もって感謝します！

4

2 に答える 2

0

IFコードを機能させるには、セクションをこれに置き換えます

        If .Offset(0, 2) = 0 And .Value <> "" Then
            'Copy
            'Cells A:E
            rDst.Resize(1, 5).Value = .EntireRow.Cells(1, 1).Resize(1, 5).Value
            ' Cell G
            rDst.Offset(0, 6).Value = .Value

            Set rDst = rDst.Offset(1, 0)
        End If
于 2012-08-05T06:34:39.100 に答える
0

セルをループするのではなく、オートフィルターを使用しないのはなぜですか? それは私をはるかに速くします。この例を参照してください。

コード（試行済み）

Option Explicit

Sub Sample()
    Dim shSrc As Worksheet, shDst As Worksheet
    Dim rDst As range, rng As range, rngtocopy As range
    Dim lastrow As Long

    On Error GoTo EH

    '~~> Select source and dest sheets
    Set shSrc = ThisWorkbook.Worksheets("Active Snag List")
    Set shDst = ThisWorkbook.Worksheets("Snag History")

    '~~> Select initial rows
    Set rDst = shDst.Cells(2, 1)

    With shSrc
        '~~> Remove any filters
        .AutoFilterMode = False

        '~~> Get the last row of Col G
        lastrow = .range("G" & .Rows.Count).End(xlUp).Row

        With .range("A8:G" & lastrow)
            '~~> Filter G Col for non blanks
            .AutoFilter Field:=7, Criteria1:="<>"
            '~~> Get the offset(to exclude headers)
            Set rng = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
            '~~> Remove Col F from the resulting range
            Set rngtocopy = Union(shSrc.range(Replace(rng.Address, "G", "E")), _
            shSrc.range(Replace(rng.Address, "A", "G")))
            '~~> Copy cells to relevant destination
            rngtocopy.Copy rDst
            '~~> Delete the filtered results
            rng.EntireRow.Delete
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With

    Exit Sub
EH:
    MsgBox "Error " & Err.Description
End Sub

スナップショット

マクロ実行前のシート 1

ここに画像の説明を入力

マクロ実行後のシート 2

ここに画像の説明を入力

マクロ実行後のシート 1

ここに画像の説明を入力

于 2012-08-06T02:01:23.500 に答える