Vba to 1) Add and 2) Delete rows based on Criteria entered in input box that displays on screen

Geeta2014

New Member
Joined
Aug 9, 2014
Messages
16
Office Version
  1. 2019
  2. 2016
  3. 2010
Platform
  1. Windows
Hi All,

i can find my way around vba [I am more of an Excel formula user]. Every now and then I need to use one of these. Right now, I am going through the forum and i most likely will find code pieces of what I need, and then i will combine.

However, perhaps one of you good souls already have a vba code that can accomplish what I need. I have laid it out logically as i can below. After the vba runs [whether I add or I delete], I'd like to automatically transfer the updated data to a Word file [tell me if its possible or impossible].

=(ROW()-1&"=")Argentina=(ROW()-1&"=")Argentina Need a vba code that will:
1. Search for a specific string (e.g. Barbados) that I type into an input box, Delete the row with Barbados
I also want the code to loop through and make sure the the text in Column B is in alphabetical order. (If there is a way to add numbering plus the equal sign within the code so I no longer need Column A, i am open to that also).
2=Aruba2=Aruba
3=Barbados3=Barbados 2. Need code that will loop through Column B, confirm that what I type in an input box is not present in Column B, and once confirmed, code will Add in alphabetical order a new country (e.g. Venezuela). (If there is a way to add numbering plus the equal sign within the code so I no longer need Column A, i am open to that also).
4=Bonaire4=Bonaire
5=Chile5=Chile
6=Curacao6=Curacao
7=St Lucia7=St Lucia
8=Trinidad8=Trinidad

<colgroup><col><col><col><col><col></colgroup><tbody>
</tbody>
 

Some videos you may like

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,506
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Hi,

This code will not do anything with Word yet. That said, does it fulfill your other requirements. To sort, I needed to use a temporary helper column. I used Column A, since with this code you no longer need your original Column A. If you would prefer to use a different helper column, please change where I notated and highlighted in RED.

The code also assumes that all your countries are in Column B, starting with Cell B2. If countries are duplicated they will have consecutive numbers and not unique numbers.

Code:
Sub CountryWork()
    
    Dim col, srtd, beg
    Dim lRow As Long, i As Long, n As Long, pos As Long
    Dim c As Range, B As Range, delCty As Range
    Dim sRch As String, nWc As String
    
    Application.ScreenUpdating = False
    sRch = InputBox("What country would you like to delete?", "DELETE COUNTRY")
    lRow = Cells(Rows.Count, 2).End(xlUp).Row
    beg = Range("B2:B" & lRow)
    For n = LBound(beg) To UBound(beg)
        If IsNumeric(Left(beg(n, 1), 1)) Then
            pos = InStr(beg(n, 1), "=")
            beg(n, 1) = Mid(beg(n, 1), pos + 1)
        End If
    Next
    Range("B2").Resize(UBound(beg)) = beg
    
Again:


    On Error GoTo NXT
    Set c = Range("B2:B" & lRow)
    Set delCty = c.Find(WHAT:=sRch, SearchOrder:=xlRows, _
      SearchDirection:=xlPrevious, LookIn:=xlFormulas)
    delCty.EntireRow.Delete
    GoTo Again
      
NXT:


    nWc = InputBox("Would you like to add a new country, if not click Cancel")
    If Not nWc = "" Then
        lRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
        
        Set delCty = c.Find(WHAT:=nWc, SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas)
        If Not delCty Is Nothing Then
            MsgBox "Country already exists!", vbCritical
            GoTo FinishUP
        End If
        Range("B" & lRow) = nWc
        col = Range("B2:B" & lRow)
    End If
    
FinishUP:


    lRow = Cells(Rows.Count, 2).End(xlUp).Row
    col = Range("B2:B" & lRow)
    With Range("[COLOR=#ff0000]A[/COLOR]1") ' [COLOR=#ff0000]Change this cell from Column A to a different Column[/COLOR]
        .Resize(UBound(col)) = col
        .CurrentRegion.Sort Range("[COLOR=#ff0000]A[/COLOR]1"), , , , , , , 0  '[COLOR=#ff0000]here also[/COLOR]
        srtd = .CurrentRegion
        .CurrentRegion.Clear
    End With
    
    For i = LBound(srtd) To UBound(srtd) - 1
        srtd(i, 1) = i & "=" & srtd(i, 1)
    Next
    Range("B2").Resize(UBound(srtd)) = srtd
    Application.ScreenUpdating = True
  
End Sub

I hope this helps...
 

Geeta2014

New Member
Joined
Aug 9, 2014
Messages
16
Office Version
  1. 2019
  2. 2016
  3. 2010
Platform
  1. Windows
thank you. it works. Is possible to give it to me in 2 pieces? See, I plan to add the codes into an 'Add' and 'Delete' Userform button [learning curve for some non-excel users].
btw, i have a drinking item [its not a problem for me! the more I drink, the better I feel]
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,506
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Is this what you are looking for. Alcohol just works!!

Code:
Sub CountryWorkDel()
    
    Dim col, srtd, beg
    Dim lRow As Long, i As Long, n As Long, pos As Long
    Dim c As Range, B As Range, delCty As Range
    Dim sRch As String, nWc As String
    
    Application.ScreenUpdating = False
    sRch = InputBox("What country would you like to delete?", "DELETE COUNTRY")
    lRow = Cells(Rows.Count, 2).End(xlUp).Row
    beg = Range("B2:B" & lRow)
    For n = LBound(beg) To UBound(beg)
        If IsNumeric(Left(beg(n, 1), 1)) Then
            pos = InStr(beg(n, 1), "=")
            beg(n, 1) = Mid(beg(n, 1), pos + 1)
        End If
    Next
    Range("B2").Resize(UBound(beg)) = beg
    
Again:


    On Error GoTo NXT
    Set c = Range("B2:B" & lRow)
    Set delCty = c.Find(WHAT:=sRch, SearchOrder:=xlRows, _
      SearchDirection:=xlPrevious, LookIn:=xlValues, Lookat:=xlWhole)
    delCty.EntireRow.Delete
    GoTo Again
      
NXT:


    lRow = Cells(Rows.Count, 2).End(xlUp).Row
    col = Range("B2:B" & lRow)
    With Range("A1") ' Change this cell from Column A to a different Column
        .Resize(UBound(col)) = col
        .CurrentRegion.Sort Range("A1"), , , , , , , 0  'here also
        srtd = .CurrentRegion
        .CurrentRegion.Clear
    End With
    
    For i = LBound(srtd) To UBound(srtd) - 1
        srtd(i, 1) = i & "=" & srtd(i, 1)
    Next
    Range("B2").Resize(UBound(srtd)) = srtd
    Application.ScreenUpdating = True
  
End Sub


Sub CountryWorkAdd()
    
    Dim col, srtd, beg
    Dim lRow As Long, i As Long, n As Long, pos As Long
    Dim c As Range, B As Range, delCty As Range
    Dim sRch As String, nWc As String
    
    Application.ScreenUpdating = False
    lRow = Cells(Rows.Count, 2).End(xlUp).Row
    beg = Range("B2:B" & lRow)
    For n = LBound(beg) To UBound(beg)
        If IsNumeric(Left(beg(n, 1), 1)) Then
            pos = InStr(beg(n, 1), "=")
            beg(n, 1) = Mid(beg(n, 1), pos + 1)
        End If
    Next
    Range("B2").Resize(UBound(beg)) = beg


    Set c = Range("B2:B" & lRow)


    nWc = InputBox("Would you like to add a new country, if not click Cancel")
    If Not nWc = "" Then
        lRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
        
        Set delCty = c.Find(WHAT:=nWc, SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas, Lookat:=xlWhole)
        If Not delCty Is Nothing Then


            MsgBox "Country already exists!", vbCritical
            GoTo FinishUP
        End If
NotFound:
        If nWc = "" Then GoTo FinishUP
        Range("B" & lRow) = nWc
        col = Range("B2:B" & lRow)
    End If
    
FinishUP:


    lRow = Cells(Rows.Count, 2).End(xlUp).Row
    col = Range("B2:B" & lRow)
    With Range("A1") ' Change this cell from Column A to a different Column
        .Resize(UBound(col)) = col
        .CurrentRegion.Sort Range("A1"), , , , , , , 0  'here also
        srtd = .CurrentRegion
        .CurrentRegion.Clear
    End With
    
    For i = LBound(srtd) To UBound(srtd) - 1
        srtd(i, 1) = i & "=" & srtd(i, 1)
    Next
    Range("B2").Resize(UBound(srtd)) = srtd
    Application.ScreenUpdating = True
  
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,122,521
Messages
5,596,650
Members
414,083
Latest member
Mrsash

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top