vba - 删除前两列中的值，但第一列中的值等于工作表名称的行除外 VBA

Question

我正在尝试找到代码第二部分的解决方案。 我有一个包含 5 列的表，其中包含大约 70 条记录(每次的数量不同)，我需要为每条记录创建新的电子表格(每个选项卡被命名为第一列中的记录编号)，其中前两条记录中的其他记录的值列将被隐藏(删除/删除)。表格的第一行和最后一行不应隐藏，因为它们包含列标题和总计公式(第五列也包含公式)。

我已经成功创建了一个代码来解决问题的第一部分，即创建包含所有数据的电子表格并更改这些选项卡的名称。但我仍然无法弄清楚如何在电子表格中仅保留一条记录的值，并隐藏/删除/删除其他记录的前两列中的值。

这是我的代码，如果有任何帮助，我将不胜感激!

Sub Create()
    Dim I As Long
    Dim xNumber As Integer
    Dim xName As String
    Dim ws As Worksheet
    Dim rg As Range
    Dim lastRow As Long

    On Error Resume Next
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    lastRow = ws.Range("B" & ws.Rows.Count).End(xlUp - 1).Row
    Set rg = Range("A1:A" & lastRow)

    xNumber = InputBox("Enter number of times to copy the current sheet")
    For I = 1 To xNumber
        xName = ActiveSheet.Name
        ws.Copy After:=ActiveWorkbook.Sheets(xName)
        ActiveSheet.Name = ws.Range("A" & I + 1).Value

        With rg
            .AutoFilter Field:=1, Criteria1:=ActiveSheet.Name
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireColumn.Clear
        End With

    Next
    ws.Activate
    Application.ScreenUpdating = True
End Sub

Answer 1

这是一个答案，其中包含一些代码:

• 循环浏览所有工作表
• 查找当前工作表名称(如果不存在则不执行任何操作)
• 删除/清除单元格，直到只剩下 3 行

根据自己的喜好进行调整

Sub DoStuff1()

Dim WS As Worksheet
Dim LR As Long, FR As Long
Dim CL As Range
Application.ScreenUpdating = False 'Turn the screen refresh off

For Each WS In ThisWorkbook.Sheets 'Loop through your sheets
    WS.Activate
StartHere: LR = WS.Cells(Rows.Count, "A").End(xlUp).Row - 1 'Get the dynamic last used row
    Set CL = WS.Columns(1).Find(What:=WS.Name, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CL Is Nothing Then
        FR = CL.Row 'Get the row which is the value
        If FR > 2 And FR < LR Then 'If larger than 2 but smaller than last used row then
            WS.Range(Cells(2, 1), Cells(FR - 1, 2)).Delete Shift:=xlUp
            GoTo StartHere
        ElseIf FR = 2 And FR < LR Then 'If FR = 2 but still some rows between FR and LR
            WS.Range(Cells(FR + 1, 1), Cells(LR, 2)).Delete Shift:=xlUp
            GoTo StartHere
        ElseIf FR = LR And FR > 2 Then 'If A is the lastrow with a value but rows between 2 and FR
            WS.Range(Cells(2, 1), Cells(FR - 1, 2)).Delete Shift:=xlUp
            GoTo StartHere
        Else
            'If there is only the startrow, the foundrow with value and the very last row left...
        End If
    End If
Next WS

Application.ScreenUpdating = True 'Turn the screen refresh back on
End Sub

编辑:第二个选项，清除单元格而不是删除

Sub DoStuff2()

Dim WS As Worksheet
Dim LR As Long, FR As Long
Dim CL As Range
Application.ScreenUpdating = False

For Each WS In ThisWorkbook.Sheets
    WS.Activate
    LR = WS.Cells(Rows.Count, "A").End(xlUp).Row - 1
    Set CL = WS.Columns(1).Find(What:=WS.Name, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CL Is Nothing Then
        FR = CL.Row
        If FR > 2 And FR < LR Then WS.Range(Cells(2, 1), Cells(FR - 1, 2)).ClearContents
        If FR < LR And FR > 2 Then WS.Range(Cells(FR + 1, 1), Cells(LR, 2)).ClearContents
        If FR = 2 And FR < LR Then WS.Range(Cells(FR + 1, 1), Cells(LR, 2)).ClearContents
        If FR = LR And FR > 2 Then WS.Range(Cells(2, 1), Cells(FR - 1, 2)).ClearContents
    End If
Next WS

Application.ScreenUpdating = True
End Sub