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列中的特定措辞，即Fan或Heater，然后将其移到底部，在那里用一行说明季节项目。

见下图结果：

为什么我希望它与众不同是因为这些东西在流动和在点变化...这会使它更简单，我也希望代码更短，而不是每次我必须检查并在运行之前编辑代码...

感谢您抽出宝贵时间查看此内容，并在可能的情况下提供解决方案。

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

Excel VB，使用新标题

1 个答案: