Delete cells and columns based on a cell entry

Question

I want to delete cells in specific columns.

Sub do_it()

    Dim sht As Worksheet, n As String, cell, num, tmp, rngDest As Range, i As Integer
    Set sht = ActiveSheet
    n = sht.Range("A1").Value
    i = 0
    For Each cell In sht.Range("A20:A34,D20:D34,H20:H34").Cells
        tmp = cell.Offset(0, 1).Value
        If cell.Value = n And tmp Like "*#-#*" Then
            'get the first number
            num = CLng(Trim(Split(tmp, "-")(0)))

            'find the next empty cell in the appropriate    row
            Set rngDest = sht.Cells(num, sht.Columns.Count).End(xlToLeft).Offset(0, 1)

            'make sure not to add before col J
            If rngDest.Column < 12 Then Set rngDest = sht.Cells(num, 12)
            cell.Offset(0, 1).Copy rngDest

            ' This is getting the next number in A/D/H----
            Set tmp = cell.Offset(1, 0)

            ' This is filling up B17 - F18 in order until filled
            If sht.Range("B17").Value = "" Then
                sht.Range("C17").Value = cell.Offset(0, 1).Value
                sht.Range("B17").Value = tmp.Value
            ElseIf sht.Range("C18").Value = "" Then
                sht.Range("C18").Value = cell.Offset(0, 1).Value
                sht.Range("B18").Value = tmp.Value
            ElseIf sht.Range("E17").Value = "" Then
                sht.Range("E17").Value = cell.Offset(0, 1).Value
                sht.Range("D17").Value = tmp.Value
            ElseIf sht.Range("E18").Value = "" Then
                sht.Range("E18").Value = cell.Offset(0, 1).Value
                sht.Range("D18").Value = tmp.Value
            End If

            '---- This clears the B columns  after using the value ----
            Dim rg As Range, rg1 As Range
            If cell.Column = 1 Then
                Set rg = cell.Offset(, 1).Resize(, 1)
                If cell.Column > 1 Then Set rg1 = cell.Offset(, 1).Resize(, 2)
            End If
        End If
    Next cell
    If Not rg Is Nothing Then rg.ClearContents  'will be delete column b
    'If Not rg1 Is Nothing Then  rg1.ClearContents 'will be delete column e,f,g,
End Sub

The issue is deleting the correct column after the copy and paste process.

Using the Excel image:

When a number entered in cell A1 (8 in this case) is found in the cell range A20:A34 (cell B34), in only this cell range do I need the contents of cell B34 to be deleted after being copied and pasted.

When the number is found in cell ranges D20:D34 and H20:H34, I need cells E20/F20/G20 AND I/J/K to be deleted after the copy and paste function is done.

Excel sheet:

Dim sht As Worksheet, n As String, cell, num, tmp, rngDest As Range declares rngDest as Range but cell,num, tmp as Variant. Was that your intention? — John Coleman
It works but can I ask what the issue is. I'm getting there but my VBA experience isn't anywhere yours. Thank-you for your help. — NANCY SKYES
I just checked and this my original; Sub do_it() Dim n, sht As Worksheet, cell As Range, num, tmp, rngDest As Range Set sht = ActiveSheet n = sht.Range("A1") For Each cell In sht.Range("A15:A30,C15:C30,E15:E30,G15:G30,I15:I30").Cells tmp = cell.Offset(0, 1).Value If cell.Value = n And tmp Like "#-#" Then 'get the first number num = CLng(Trim(Split(tmp, "-")(0))) Debug.Print "Found a positive result in " & cell.Address — NANCY SKYES
The rest; 'find the next empty cell in the appropriate row Set rngDest = sht.Cells(num, sht.Columns.Count).End(xlToLeft).Offset(0, 1) 'make sure not to add before col L If rngDest.Column < 12 Then Set rngDest = sht.Cells(num, 12) cell.Offset(0, 1).Copy rngDest End If Next End Sub — NANCY SKYES

Abdallah El-Yaddak Abdallah El-Yaddak · Accepted Answer · 2020-04-05T08:21:05

Welcome on board!

In order to achieve this:

When a number entered in cell A1 (8 in this case) is found in the cell range A20:A34 (cell B34), in only this cell range, do I need the contents of cell B34 to be deleted after being copied and pasted.

When the number is found in cell ranges D20:D34 and H20:H34, I need cells E20/F20/G20 AND I/J/K to be deleted after the copy and paste function is done.

You need to replace this part of your code:

        Dim rg As Range, rg1 As Range
        If cell.Column = 1 Then
            Set rg = cell.Offset(, 1).Resize(, 1)
            If cell.Column > 1 Then Set rg1 = cell.Offset(, 1).Resize(, 2)
        End If

With this:

        Select Case cell.Column
        Case 1 'If found in column A, delete the next cell
            cell.Offset(, 1).ClearContents
        Case 4, 8 'If found in column D or H, delete cells E20/F20/G20 AND I/J/K
            Range("D20:D34,H20:H34,I:I,J:J,K:K").ClearContents
        End Select

Delete cells and columns based on a cell entry

1 Answers