CODEWITHSUNDEEP
vbaexcel
Tart
Tart

Reputation: 305

Remove values in first two columns except the row where a value in the first column equals the name of the sheet 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).

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

Upvotes: 3

Views: 405

Answers (1)

JvdV
JvdV

Reputation: 75960

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

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

Upvotes: 2

Related Questions