简体   繁体   中英

My loops seems to be filling information even if a match isn't found

I have the loop below that I use to find information in another sheet and fill into the one I'm working on. I would like the loop to not update if a value isn't found. However it seems to update with the line above and I can't figure out why. Your help would be greatly appreciated.

updrng1 is the cell I'm using for my loop and WorkRng1 is the range for my current sheet I'd like updated WorkRng2 is the range that the identifier in WorkRng1 I'm looking for a match

Public variables:

Option Explicit
Public WorkRng1 As Range
Public WorkRng2 As Range
Public WorkRng3 As Range
Public Rng1 As Range
Public Rng2 As Range
Public Rng3 As Range
Public blkRow As Range
Public subTskRng As Range
Public UOMRng As Range
Public nmbrRng As Range
Public unitCostRng As Range

This is my form code:

Private Sub CommandButton1_Click()
Dim updRange1 As Range

Set updRange1 = Application.InputBox("Please select all Tasks ID Cells you would like to update", "Title", Type:=8)
Application.ScreenUpdating = False

updRange1.NumberFormat = "@"

Dim matchCounter As Integer
matchCounter = 0

Dim FoundRange As Range
    For Each updrng1 In updRange1
    ''tests task exists in work range 2
    WorkRng2.Parent.Activate
    If updrng1 <> 0 Then
        Set FoundRange = WorkRng2.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If FoundRange Is Nothing Then
            MsgBox "test" & updrng1
        Else
    'updates subtask info
            WorkRng2.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
            If Cells(ActiveCell.Row, subTskRng.Column) <> 0 Then
                Cells(ActiveCell.Row, subTskRng.Column).Copy
            Else
                Cells(ActiveCell.Row, subTskRng.Column - 1).Copy
        End If
        WorkRng1.Parent.Activate
        updRange1.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, Me.txtSubTask.Value).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    'updates UOM info
        WorkRng2.Parent.Activate
        WorkRng2.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, UOMRng.Column).Copy
        WorkRng1.Parent.Activate
        updRange1.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, Me.txtUOM.Value).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    'updates Number of units info
        WorkRng2.Parent.Activate
        WorkRng2.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, nmbrRng.Column).Copy
        WorkRng1.Parent.Activate
        updRange1.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, Me.txtNoUnits.Value).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    'updates Units Cost info
        WorkRng2.Parent.Activate
        WorkRng2.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, unitCostRng.Column).Copy
        WorkRng1.Parent.Activate
        updRange1.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, Me.txtUnitCost.Value).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        If Me.txtBgtTotal.Value <> "" Then
            Cells(ActiveCell.Row, Me.txtBgtTotal.Value).Formula = "=" & Me.txtNoUnits.Value & updrng1.Row & "*" & Me.txtUnitCost.Value & updrng1.Row
        End If
        matchCounter = matchCounter + 1
    End If
    End If
    Next

    updRange1.NumberFormat = "0.0"

Application.ScreenUpdating = True
If matchCounter > 0 Then MsgBox matchCounter & " Tasks Updated!", vbInformation, "Success!"
    'Clear input controls
    Me.txtSubTask.Value = ""
    Me.txtUOM.Value = ""
    Me.txtNoUnits.Value = ""
    Me.txtUnitCost.Value = ""
    Me.txtBgtTotal.Value = ""
    txtSubTask.SetFocus
    Exit Sub
Whoa:
        Select Case Err.Number
            Case 1004
                MsgBox "Check Your Column Letters!", vbInformation, "Oops!"
        End Select

End Sub

With the help of everyone in the comments I was able to get the code below working. Bonus: I even added in a mismatch error counter that displays the array in a txtbox.

For those interested here is my working code:

Private Sub CommandButton1_Click()
Dim updRange1 As Range
Dim list As String
On Error GoTo Whoa
Set updRange1 = Application.InputBox("Please select all Tasks ID Cells you would like to update", "Update Range", Type:=8)
Application.ScreenUpdating = False

updRange1.NumberFormat = "@"

Dim matchCounter As Integer
Dim errorCounter As Integer
matchCounter = 0
errorCounter = 0
Dim FoundRange As Range

    For Each updrng1 In updRange1
    ''tests task exists in work range 2
    WorkRng2.Parent.Activate
    If updrng1 <> 0 And updrng1 <> "Sub Total - Labor Fees" And updrng1 <> "Sub Total - Meetings" And updrng1 <> 21 Then
        Set FoundRange = WorkRng2.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If FoundRange Is Nothing Then
            list = list & updrng1 & ", "
            errorCounter = errrorCounter + 1
        Else
    'updates subtask info
    If Me.txtSubTask.Value <> 0 Then
            WorkRng2.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
            If Cells(ActiveCell.Row, subTskRng.Column) <> 0 Then
                Cells(ActiveCell.Row, subTskRng.Column).Copy
            Else
                Cells(ActiveCell.Row, subTskRng.Column - 1).Copy
            End If
        WorkRng1.Parent.Activate
        updRange1.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, Me.txtSubTask.Value).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    End If
    'updates UOM info
    If Me.txtUOM.Value <> 0 Then
        WorkRng2.Parent.Activate
        WorkRng2.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, UOMRng.Column).Copy
        WorkRng1.Parent.Activate
        updRange1.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, Me.txtUOM.Value).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    End If
    'updates Number of units info
    If Me.txtNoUnits.Value <> 0 Then
        WorkRng2.Parent.Activate
        WorkRng2.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, nmbrRng.Column).Copy
        WorkRng1.Parent.Activate
        updRange1.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, Me.txtNoUnits.Value).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    End If
    'updates Units Cost info
    If Me.txtUnitCost.Value <> 0 Then
        WorkRng2.Parent.Activate
        WorkRng2.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, unitCostRng.Column).Copy
        WorkRng1.Parent.Activate
        updRange1.Find(what:=updrng1.Value, LookIn:=xlValues, LookAt:=xlWhole).Select
        Cells(ActiveCell.Row, Me.txtUnitCost.Value).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    End If
    If Me.txtBgtTotal.Value <> "" Then
        Cells(ActiveCell.Row, Me.txtBgtTotal.Value).Formula = "=" & Me.txtNoUnits.Value & updrng1.Row & "*" & Me.txtUnitCost.Value & updrng1.Row
    End If
        matchCounter = matchCounter + 1
    End If
    End If
    Next

    updRange1.NumberFormat = "0.0"

Application.ScreenUpdating = True
If matchCounter > 0 Then MsgBox matchCounter & " Tasks Updated!", vbInformation, "Success!"
If errorCounter > 0 Then MsgBox "Mismatches: " & list, vbInformation, "Please update the following tasks manually!"
    'Clear input controls
    Me.txtSubTask.Value = ""
    Me.txtUOM.Value = ""
    Me.txtNoUnits.Value = ""
    Me.txtUnitCost.Value = ""
    Me.txtBgtTotal.Value = ""
    txtSubTask.SetFocus
    Exit Sub
Whoa:
        Select Case Err.Number
            Case 1004
                MsgBox "Check Your Column Letters!", vbInformation, "Oops!"
        End Select

End Sub

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM