0

このテーブルはデータでいっぱいです。また、各行の列 K には数値が含まれています。したがって、基本的に私がやろうとしているのは、その列のデータが 9 より大きい場合、行全体をシート 2 に移動することです。

これはどのように達成できますか？Table1 と Table2 という実際のテーブルをシートに既に作成しています。

これが、私がこれまでにまとめることができたものです。オートフィルターを見てきましたが、そこで何が起こっているのか理解できません。だからこれは私が得る！

Sub MoveData()

    Dim i As Range
    Dim num As Integer
     num = 1
    For Each i In Range("K10:K1000")
        If i.Value > 9 Then
            i.Select
            ActiveCell.Rows("1:1").EntireRow.Select
            Selection.Copy

            Sheets("Sheet2").Range("A65000").End(xlUp).Offset(num, 0).PasteSpecial
            ActiveCell.Rows.Delete
            num = num + 1

        End If
    Next i
End Sub

これはこれまでのところうまくいきます。しかし、行をシート2の次の空白行に貼り付けることができません。その num = num + 1 をやってみましたが、それはかなりずれていると思いますか?

4

1 に答える 1

2

これはあなたがしようとしていることですか？(試行錯誤)

Option Explicit

Sub Sample()
    Dim wsI As Worksheet, wsO As Worksheet
    Dim rRange As Range

    Dim lastRowWsO As Long

    Set wsI = Sheets("sheet1")

    '~~> Assuming that the Header is in K10
    Set rRange = wsI.Range("K10:K1000")

    Set wsO = Sheets("sheet2")

    '~~> Get next empty cell in Sheet2
    lastRowWsO = wsO.Range("A" & Rows.Count).End(xlUp).Row + 1

    With wsI
        '~~> Remove Auto Filter if any
        .AutoFilterMode = False

        With rRange
            '~~> Set the Filter
            .AutoFilter Field:=1, Criteria1:=">=9"

            '~~> Temporarirly hide the unwanted rows
            wsI.Rows("1:9").EntireRow.Hidden = True
            wsI.Rows("1001:" & Rows.Count).EntireRow.Hidden = True

            '~~> Copy the Filtered rows
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            wsO.Rows(lastRowWsO)

            '~~> Delete The filtered rows
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

        '~~> Unhide the rows
        .Rows("1:9").EntireRow.Hidden = False
        .Rows("1001:" & Rows.Count).EntireRow.Hidden = False

        '~~> Remove Auto Filter
        .AutoFilterMode = False
    End With
End Sub

注: エラー処理は含めていません。最終的なコードに含めることをお勧めします

ファローアップ

Sub Sample()
    Dim wsI As Worksheet, wsO As Worksheet
    Dim rRange As Range

    Dim lastRowWsI As Long, lastRowWsO As Long

    Set wsI = Sheets("Risikoanalyse")

    '~~> Assuming that the Header is in K10
    Set rRange = wsI.Range("K9:K1000")

    lastRowWsI = wsI.Cells.Find(What:="*", _
                After:=wsI.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row


    Set wsO = Sheets("SJA utarbeides")

    '~~> Get next empty cell in Sheet2
    lastRowWsO = wsO.Cells.Find(What:="*", _
                After:=wsO.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row + 1

    With wsI
        With .ListObjects("TableRisikoAnalyse")
            '~~> Set the Filter
            .Range.AutoFilter Field:=11, Criteria1:=">=9"

            '~~> Temporarirly hide the unwanted rows
            wsI.Rows("1:8").EntireRow.Hidden = True
            wsI.Rows(lastRowWsI & ":" & Rows.Count).EntireRow.Hidden = True

            '~~> Copy the Filtered rows
            wsI.Range(Replace(wsI.Range("K9").Offset(1, 0).SpecialCells(xlCellTypeVisible).Address, "$9:$9,", "")).EntireRow.Copy _
            wsO.Rows(lastRowWsO)

            '~~> Clear The filtered rows
            wsI.Range(Replace(wsI.Range("K9").Offset(1, 0).SpecialCells(xlCellTypeVisible).Address, "$9:$9,", "")).Clear

            .Range.AutoFilter Field:=11

            '~~> Sort the table so that blank cells are pushed down                
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=Range("TableRisikoAnalyse[[ ]]"), SortOn:=xlSortOnValues, Order _
            :=xlAscending, DataOption:=xlSortTextAsNumbers
            With .Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With

        '~~> Unhide the rows
        .Rows("1:8").EntireRow.Hidden = False
        .Rows(lastRowWsI & ":" & Rows.Count).EntireRow.Hidden = False

        '~~> Remove Auto Filter
        .AutoFilterMode = False
    End With
End Sub
于 2012-04-20T09:35:53.450 に答える