使用VBA將某些數據向右移動

Question

在列表中，我想將非「P」項移到同一工作表的右側。然後我需要複製「P」項目以匹配右側的項目數量。請參閱示例進行說明。

Right Click on Link and Save File for Sample

感謝您的任何援助。

Answer 1

試試這個：

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 

Answer 2

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