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

I'm trying to find a solution to a second part of the code. I have a table with 5 columns containing about 70 records (every time different number) and I need to create new spreadsheets (each tab is named as a record number in the first column) for each record where values for other records in the first two columns will be hidden(removed/deleted). The first row and the last row of the table shouldn't be hidden as they contain columns' headers and Total formulas (5th column contains formulas as well).

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

I've managed to create a code to solve the first part of the problem of creating spreadsheets with all data and changing names for those tabs. But I still cannot figure out how to keep only values for one record in a spreadsheet and hide/remove/delete values in the first two columns for other records.

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

Here is the code I have, would be grateful for any help!

这是我的代码,非常感谢任何帮助!

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

1 个解决方案

#1

Here is an answer with some code that will:

以下是一些代码的答案:

Loop through all your sheets

循环遍历所有表格

Looking for current sheet name (If not there then do nothing)

寻找当前的工作表名称(如果不存在那么什么都不做)

Delete/clear cells untill there is just the 3 rows left

删除/清除单元格,直到只剩下3行

Adjust to your liking

根据自己的喜好调整

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

EDIT: Second option, clearing cells instead of deleting

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

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

#1