Jump to content
Fórum Script Brasil
  • 0

Remova as linhas com base no valor da célula com código VBA


Cristiano Vidal

Question

Bom dia!

BONFÁ 02 10 12 26 51 56 67 69 73 77
CAPITÃO AMÉRICA 05 11 14 19 37 53 61 73 85 88
CARLIM 01 12 23 33 38 44 49 55 60 83
CARLINHO 01 05 11 12 13 16 17 20 21 27
CESAR OLEGARIO 11 33 46 59 65 69 73 75 79 93
CLAUDIO PA 01 04 08 13 17 25 30 92 99 00
CRIS BH 07 10 12 15 18 31 33 36 85 96
DAMIÃO 08 26 44 58 60 64 66 81 82 91
DIA DE SORTE 12 16 21 27 28 42 65 67 78 88
DIRCE 05 33 45 59 64 65 69 70 71 95
DR MARCOS 03 09 28 34 37 43 54 69 74 88
EDENILSOM 04 16 28 38 43 59 84 93 94 99

acima é como são minhas linhas, eu queria q o VBA selecionasse da coluna H (nome) até coluna R (último número da linha) mas com o código abaixo ele seleciona a linha inteira, é possivel adaptar esse código?

 

Sub DeleteRows()

'Updateby20211217

Dim rng As Range

Dim InputRng As Range

Dim DeleteRng As Range

Dim DeleteStr As String

Dim xTitleId As String

Dim xArr

Dim xF As Integer

Dim xWSh As Worksheet

On Error Resume Next

xTitleId = "Excluir apostas"

Set rng = Application.Selection

Set InputRng = Application.InputBox("Range :", xTitleId, rng.Address, Type:=8)

If InputRng Is Nothing Then Exit Sub

DeleteStr = Application.InputBox("Delete Text", xTitleId, Type:=2)

Set xWSh = InputRng.Worksheet

For Each rng In InputRng

    If rng.Value = DeleteStr Then

        If DeleteRng Is Nothing Then

            Set DeleteRng = rng

        Else

            Set DeleteRng = Application.Union(DeleteRng, rng)

            Set DeleteRng = DeleteRng.EntireRow

        End If

    End If

Next

xArr = Split(DeleteRng.AddressLocal, ",")

DeleteRng.Select

DeleteRng.Delete

For xF = UBound(xArr) To 0 Step -1

    Set DeleteRng = xWSh.Range(xArr(xF))

    DeleteRng.Delete

Next

End Sub

 

Link to comment
Share on other sites

2 answers to this question

Recommended Posts

  • 0

Se você deseja adaptar o código para selecionar apenas as colunas H até R em vez da linha inteira, você pode ajustar a maneira como o intervalo é tratado. Aqui está a versão adaptada do seu código:

Sub DeleteRows()

    ' Update by 20211217

    Dim rng As Range
    Dim InputRng As Range
    Dim DeleteRng As Range
    Dim DeleteStr As String
    Dim xTitleId As String
    Dim xArr
    Dim xF As Integer
    Dim xWSh As Worksheet

    On Error Resume Next
    xTitleId = "Excluir apostas"

    Set rng = Application.Selection
    Set InputRng = Application.InputBox("Range :", xTitleId, rng.Address, Type:=8)

    If InputRng Is Nothing Then Exit Sub

    DeleteStr = Application.InputBox("Delete Text", xTitleId, Type:=2)

    Set xWSh = InputRng.Worksheet

    For Each rng In InputRng
        ' Verifica se a célula contém o texto a ser excluído
        If rng.Value = DeleteStr Then
            ' Se DeleteRng ainda não foi definido, define-o como a célula atual
            If DeleteRng Is Nothing Then
                Set DeleteRng = rng.Offset(0, 7).Resize(, 10) ' Ajusta para selecionar da coluna H até R
            Else
                ' Caso contrário, une DeleteRng com a nova célula
                Set DeleteRng = Application.Union(DeleteRng, rng.Offset(0, 7).Resize(, 10))
            End If
        End If
    Next

    ' Exclui as células selecionadas
    If Not DeleteRng Is Nothing Then
        DeleteRng.Delete
    End If

End Sub

As alterações foram feitas na linha:

Set DeleteRng = rng.Offset(0, 7).Resize(, 10)

Essa linha ajusta DeleteRng para começar da coluna H (Offset(0, 7)) e se estender até a coluna R (Resize(, 10)). Isso garante que somente as colunas desejadas sejam selecionadas para exclusão. Certifique-se de testar o código para garantir que ele atenda aos seus requisitos.

 

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Answer this question...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.



  • Forum Statistics

    • Total Topics
      152.1k
    • Total Posts
      651.9k
×
×
  • Create New...