excel - VBA を使用して特定のデータを右に移動する

Question

リストで、「P」以外のアイテムを同じシートの右側に移動したい。次に、「P」項目を下にコピーして、右側の項目数と一致させる必要があります。明確にするために例を参照してください。

リンクを右クリックしてサンプル用のファイルを保存

ご協力ありがとうございます。

Answer 1

Sub MoveP()
' Move non P rows to right,
' starting with the row of the P above it,
' and add P info on each row

' If you want to backup before starting uncomment next two rows of code
'    Sheets("Raw Data").Select
'    Sheets("Raw Data").Copy Before:=Sheets(1)

Dim maxRows as Integer
Dim emptyRowsToStopAt
Dim emptyRows
Dim cell1Text As String
Dim currentRightRow As Integer
Dim currentPRow As Integer

maxRows = 150 ' change this if you want to process more (or less)
emptyRowsToStopAt = 5
currentRightRow = 0
currentPRow = 0

For i = 2 To maxRows

    If emptyRows > emptyRowsToStopAt Then 
       Exit For
    End If

    cell1Text = Cells(i, 1)
    Dim startsWithP As Boolean
    startsWithP = InStr(1, cell1Text, "P")

    If startsWithP Then
        currentPRow = i
        currentRightRow = currentPRow ' we start with the same line

        emptyRows = 0

    ElseIf IsEmpty(Cells(i, 1)) Or Cells(i, 1) = "" Then
    '    ' its an empty cell
        emptyRows = emptyRows + 1

    Else ' its a non P entry
        emptyRows = 0
        'copy info from left to correct line on right
        Range(Cells(i, 1), Cells(i, 11)).Select
        Selection.Cut
        Range(Cells(currentRightRow, 13), Cells(currentRightRow, 13)).Select
        ActiveSheet.Paste

        ' duplicate PRow to left (when non-p was not copied to PRow)
        ' -- see note below: only 3 cells duplicated
        If currentPRow <> currentRightRow Then ' not on the original P Row
            ' copy p heading
            Range(Cells(currentPRow, 1), Cells(currentPRow, 3)).Select 
            ' only first 3 cells copied
            ' change '3' to '11' if you want all
            Selection.Copy

            ' past p heading on current row
            Range(Cells(i, 1), Cells(i, 1)).Select
            ActiveSheet.Paste
        End If ' non p row copied to originally non p row

        ' and mark current row as written
        currentRightRow = currentRightRow + 1
    End If
Next

Call CleanupPtable

End Sub

Sub CleanupPtable()
'
' Clean up the P table Macro
' Adapted from macro recorded 08/06/2012 by pashute
'
    Range(Cells(1, 1), Cells(1, 11)).Select
    Selection.Copy
    Range("M1").Select
    ActiveSheet.Paste

    ' yellow column
    Columns("L:L").Select
    Selection.Interior.ColorIndex = 36

    ' yellow column lines
    Columns("L:L").Select
    ' Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    ' Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    '   With Selection.Borders(xlInsideVertical)
    '    .LineStyle = xlContinuous
    '    .Weight = xlThin
    '    .ColorIndex = xlAutomatic
    ' End With
    With Selection.Borders(xlInsideHorizontal)
       .LineStyle = xlContinuous
       .Weight = xlThin
       .ColorIndex = xlAutomatic
    End With

    ' yellow column width
    Selection.ColumnWidth = 2.43

    ' Automatic filters to all fields
    Rows("1:1").Select
    Selection.AutoFilter

    ' autofit
    Cells.Select
    Cells.EntireColumn.AutoFit

End Sub

Answer 2

これを試して：

Sub HTH()
    Dim vArray As Variant
    Dim rCell As Range

    Application.ScreenUpdating = False

    For Each rCell In Worksheets("Raw Data").UsedRange.Resize(, 1)
        With rCell
            If UCase(Left(.Value, 1)) = "P" Then
                vArray = .Resize(, 11).Value
            ElseIf IsNumeric(.Value) And Not IsEmpty(.Value) Then
                .Offset(-1, 12).Resize(, 11).Value = .Resize(, 11).Value
                If IsNumeric(.Offset(1).Value) And Not IsEmpty(.Offset(1).Value) Then
                    .Resize(, 11).Value = vArray
                Else
                    .Resize(, 11).Value = ""
                End If
            End If
        End With
    Next      

    Application.ScreenUpdating = True

End Sub

ヘッダーを手動でコピーするだけでよいと思いましたが、自動化する必要がある場合は、これを追加します。

With Worksheets("Raw Data")
    .Cells(1, "M").Resize(, 11).Value = .Cells(1, 1).Resize(, 11).Value
End With

中央に黄色のハイライトが必要な場合は、これを追加します。

 With Columns("L:L").Interior
    .Pattern = xlSolid
    .Color = 65535
 End With