时间戳

首页 > 解决方案 > 删除前两列中的值，但第一列中的值等于工作表 VBA 名称的行除外

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

问题描述

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

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

这是我的代码，将不胜感激任何帮助！

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

标签： vbaexcel

解决方案

这是一些代码的答案：

  • 循环浏览所有工作表
  • 寻找当前工作表名称（如果不存在则什么也不做）
  • 删除/清除单元格，直到只剩下 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

推荐阅读