エクセルVB、私は私は私のコードで取得したい結果を得ることができる午前新しいは

Question

を見出して分離見つけると、リストの一番下に行を移動：

Sub Button1_Click() 
With Worksheets("Data").Select 
    With Range("A11:H11").Select 
     With Selection.Interior 
     .Pattern = xlSolid 
     .PatternColorIndex = xlAutomatic 
     .ThemeColor = xlThemeColorLight1 
     .TintAndShade = 0 
     .PatternTintAndShade = 0 
      With Selection.Font 
      .ThemeColor = xlThemeColorDark1 
      .TintAndShade = 0 
       With Range("E11").Select 
       ActiveCell.FormulaR1C1 = "Seasonal Items" 
        With Selection 
        .HorizontalAlignment = xlGeneral 
        .VerticalAlignment = xlCenter 
        .WrapText = False 
        .Orientation = 0 
        .AddIndent = False 
        .IndentLevel = 0 
        .ShrinkToFit = False 
        .ReadingOrder = xlContext 
        .MergeCells = False 
         With Selection 
          .HorizontalAlignment = xlCenter 
          .VerticalAlignment = xlCenter 
          .WrapText = False 
          .Orientation = 0 
          .AddIndent = False 
          .IndentLevel = 0 
          .ShrinkToFit = False 
          .ReadingOrder = xlContext 
          .MergeCells = False 
         End With 
        End With 
       End With 
      End With 
     End With 
    End With 
End With 
With Worksheets("Data").Select 
    With Range("B2").Select 
    Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate 
     With Selection 
     ActiveCell.EntireRow.Select 
      With Selection 
      Selection.Copy 
      Rows("12:12").Select 
      Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
      False, Transpose:=False 
       With Range("B2").Select 
       Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate 
        With Selection 
        ActiveCell.EntireRow.Select 
         With Selection 
         Selection.Delete Shift:=xlUp 
         End With 
        End With 
       End With 
      End With 
     End With 
    End With 
End With 
With Worksheets("Data").Select 
    With Range("B2").Select 
    Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate 
     With Selection 
     ActiveCell.EntireRow.Select 
      With Selection 
      Selection.Copy 
      Rows("12:12").Select 
      Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
      False, Transpose:=False 
       With Range("B2").Select 
       Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate 
        With Selection 
        ActiveCell.EntireRow.Select 
         With Selection 
         Selection.Delete Shift:=xlUp 
         End With 
        End With 
       End With 
      End With 
     End With 
    End With 
End With 
With Worksheets("Data").Select 
    With Range("B2").Select 
    Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate 
     With Selection 
     ActiveCell.EntireRow.Select 
      With Selection 
      Selection.Copy 
      Rows("12:12").Select 
      Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
      False, Transpose:=False 
       With Range("B2").Select 
       Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate 
        With Selection 
        ActiveCell.EntireRow.Select 
         With Selection 
         Selection.Delete Shift:=xlUp 
         End With 
        End With 
       End With 
      End With 
     End With 
    End With 
End With 
With Worksheets("Data").Select 
    With Range("B2").Select 
    Cells.Find(What:="Heater", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate 
     With Selection 
     ActiveCell.EntireRow.Select 
      With Selection 
      Selection.Copy 
      Rows("12:12").Select 
      Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
      False, Transpose:=False 
       With Range("B2").Select 
       Cells.Find(What:="Heater", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate 
        With Selection 
        ActiveCell.EntireRow.Select 
         With Selection 
         Selection.Delete Shift:=xlUp 
         End With 
        End With 
       End With 
      End With 
     End With 
    End With 
End With 

End Sub 

をこのコードは非常にではありませんエレガントでもなく、本当に流れる。

ファンやヒーターのB列にある特定の語句を自動的に検索し、それを下部に移動してシーズン項目を示す行で区切ります。

結果の下の写真を参照してください：私はそれは違うしたいなぜ

が原因のものがポイントで流れると変化していることにある...それはまた、それが単純で私になるだろうだろうコードをもっと短くして、実行する前に物理的にコードをチェックして編集しなくてはなりません...

ありがとうございました。

Answer 1

このようなものは、あなたが望むように行を移動しますが、あなた自身で特定の書式を追加する必要があります。

Sub test() 

Dim lRow As Integer 
Dim lrow2 As Integer 
Dim i As Integer 

lRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 5).End(xlUp).Row 

ActiveSheet.Cells(lRow + 1, 5).Value = "Seasonal Items" 

With ThisWorkbook.ActiveSheet 
For i = 2 To lRow 
lrow2 = ActiveSheet.Cells(ActiveSheet.Rows.Count, 5).End(xlUp).Row + 1 

If InStr(.Cells(i, 2), "Fan") > 0 Or InStr(.Cells(i, 2), "Heater") > 0 Then 

.Rows(lrow2 & ":" & lrow2).Value = .Rows(i & ":" & i).Value 
.Rows(i & ":" & i).ClearContents 

End If 

Next i 

For i = 2 To lrow2 

If .Cells(i, 1).Value = "" Then 

.Cells(i, 1).EntireRow.Delete 

End If 

Next i 

End With 

End Sub