Mapping Data From Source Sheet, Where Multiple Criteria is Met

R

reberryjr

Well-known Member
Joined
Mar 16, 2017
Messages
714
Office Version
  1. 365
Platform
  1. Windows
I'm trying to identify each row in a worksheet, where a certain condition exists, then map information from that row(s), to another worksheet. The below code is giving me a Type Mismatch error at the line in red font. What do I need to correct in this code; or should I be taking a different approach?

Code: 
Sub IdentifyLatePymts()

Dim ws2, ws3, ws4 As Worksheet
Dim LastRow2 As Long
Dim FindRow As Range
Dim UpdateRow As Long


Set ws2 = ThisWorkbook.Sheets("Management")
Set ws3 = ThisWorkbook.Sheets("Summaries")
Set ws4 = ThisWorkbook.Sheets("Bios")


LastRow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row


ws3.Activate
[COLOR=#ff0000]Set FindRow = ws3.Range("B:B").Find(What:="Active", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) And _[/COLOR]
[COLOR=#ff0000]              ws3.Range("F:F").Find(What:="Late", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)[/COLOR]
                If FindRow Is Nothing Then
                    Exit Sub
                Else
                    UpdateRow = FindRow.Row
                End If


ws2.Range("A" & LastRow2 + 1) = ws3.Range("D" & UpdateRow).Value






End Sub
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
Sort by date Sort by votes
Try this

This is the data table I used which I had in the sheet "Summaries"

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Active[/TD]
[TD][/TD]
[TD]D2[/TD]
[TD][/TD]
[TD]Late[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Fake[/TD]
[TD][/TD]
[TD]D3[/TD]
[TD][/TD]
[TD]No[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Active[/TD]
[TD][/TD]
[TD]D4[/TD]
[TD][/TD]
[TD]No[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]No[/TD]
[TD][/TD]
[TD]D5[/TD]
[TD][/TD]
[TD]Late[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Active[/TD]
[TD][/TD]
[TD]D6[/TD]
[TD][/TD]
[TD]Late[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

After running the code below it would copy "D2" and "D6" and insert that text into the Sheet "Management" in column A of the next available row because they met the criteria of having Active AND Late in Columns B and F.

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]D2[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]D6[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Code: 
Sub IdentifyLatePymts()

Dim CheckVal1 As String
Dim CheckVal2 As String


Dim ws2, ws3, ws4 As Worksheet
Dim LastRow2 As Long
Dim FindRow As Range
Dim UpdateRow As Long


Set ws2 = ThisWorkbook.Sheets("Management")
Set ws3 = ThisWorkbook.Sheets("Summaries")
Set ws4 = ThisWorkbook.Sheets("Bios")


ws3.Activate

Temprng = ws3.Range("D" & Rows.Count).End(xlUp).Row


For E = 2 To Temprng
CheckVal1 = Cells(E, "B").Value
CheckVal2 = Cells(E, "F").Value


If CheckVal1 = "Active" And CheckVal2 = "Late" Then
LastRow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
Range(Cells(E, "D"), Cells(E, "D")).Copy Destination:=Sheets("Management").Range("A" & LastRow2)


End If


Next E


End Sub
 
Last edited:
Upvote 0
Maybe:
Code: 
 ...
     Set FindRow = ws3.Range("B:B").Find(What:="Active", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
    
     If Not FindRow Is Nothing And FindRow.Offset(, 4).Value = "Late" Then
      UpdateRow = FindRow.Row
     Else: Exit Sub
     End If
     ...
 
Upvote 0
Osvaldo Palmeiro said:
Maybe:
Code: 
 ...
     Set FindRow = ws3.Range("B:B").Find(What:="Active", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
    
     If Not FindRow Is Nothing And FindRow.Offset(, 4).Value = "Late" Then
      UpdateRow = FindRow.Row
     Else: Exit Sub
     End If
     ...
Click to expand...

Still only will find one result. Need to add a loop in order to find all instances in the sheet where Column B and Column F meet the requirements of having "Active" and "Late". Both your code and the original poster are only going to get the first result. It seems as though you are trying to actually get all instances within the sheet however and for that you need a loop.

I'm trying to identify each row in a worksheet, where a certain condition exists, then map information from that row(s), to another worksheet.
Click to expand...
 
Last edited:
Upvote 0
Hi,
untested but try this update to your code

Rich (BB code): 
Sub IdentifyLatePymts()
    
    Dim ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim LastRow2 As Long, UpdateRow As Long
    Dim FindRow As Range
    Dim Search(1 To 2) As String, FirstAddress As String
    
    With ThisWorkbook
        Set ws2 = .Worksheets("Management")
        Set ws3 = .Worksheets("Summaries")
        Set ws4 = .Worksheets("Bios")
    End With
    
    
    LastRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
    
    Search(1) = "Active"
    Search(2) = "Late"
    
    Set FindRow = ws3.Range("B:B").Find(What:=Search(1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
    If Not FindRow Is Nothing Then
        FirstAddress = FindRow.Address
        Do
            If FindRow.Offset(, 4).Value = Search(2) Then
                LastRow2 = LastRow2 + 1
                ws2.Range("A" & LastRow2) = ws3.Range("D" & FindRow.Row).Value
            End If
            Set FindRow = ws3.Range("B:B").FindNext(FindRow)
        Loop While FirstAddress <> FindRow.Address
        
    Else
        
        MsgBox Search(1) & Chr(10) & "Record Not Found", "Not Found"
    End If
    
End Sub

Note also the correction made to your object variable declarations for worksheets.


Dave
 
Last edited:
Upvote 0
I've been able to get this code to work. Thanks for the responses.
Code: 
Sub IDLatePymts()

Dim ws, ws2, ws4 As Worksheet
Dim LastRow2, LastRowC As Long
Dim FindRow As Range
Dim TargetRow As Long


Set ws2 = ThisWorkbook.Sheets("Management")
Set ws4 = ThisWorkbook.Sheets("Bios")
LastRow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row


For Each ws In Worksheets
    If Not ws.Name = "Displays" And Not ws.Name = "Management" And Not ws.Name = "Summaries" And Not ws.Name = "Bios" And Not ws.Name = "Stats" _
    And Not ws.Name = "Pymt Tracker" And Not ws.Name = "Financials" And Not ws.Name = "Variables" Then
        LastRowC = ws.Range("CE" & ws.Rows.Count).End(xlUp).Row
        ws.Activate
        If ws.Range("CE" & LastRowC - 1).Value = "Late" Then
            ws2.Range("A" & LastRow2 + 1) = ws.Range("D" & LastRowC - 1).Value
            ws2.Range("B" & LastRow2 + 1) = ws.Range("F" & LastRowC - 1).Value
            ws2.Range("C" & LastRow2 + 1) = ws.Range("CE" & LastRowC - 1).Value
            ws2.Range("D" & LastRow2 + 1) = Format(ws.Range("CD" & LastRowC - 1).Value, "#0.00")
            'ws2.Range ("E" & LastRow1 + 1)
End If
End If


Next ws


End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Code to search job id from multiple sources and update main spreadsheet.
2
Replies
10
Views
681
mumps
mumps
D
  • Solved
VBA copying entire rows and over writing destination formatting
Replies
3
Views
359
Alex Blakenburg
A
C
  • Solved
Copy data from multiple sheets into a master sheet - VBA button stuck
Replies
3
Views
372
NdNoviceHlp
NdNoviceHlp
A
  • Solved
Procedure fails on some sheets only
Replies
2
Views
60
AlexanderBB
A
N
  • Question Question
Finding the differences then copy and paste code to a new sheet
Replies
1
Views
667
myall_blues
myall_blues

Forum statistics

Threads
1,224,823
Messages
6,181,185
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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
Back
Top