Coding works for single criteria, but how would you modify it for several criteria?

**BZ61** · 07-22-2024, 12:42 PM

Hello, I've attempted to modify this code (See below) to check a cell in Worksheet "Execution Template" column #9 (I) for multiple criteria (a total of 5 different ones) then copy specific cells in that row;before going to the next cell. After copying the specific cells in the row that met the criteria in column #9 (I) they would be pasted in sequence into worksheet "TEST" (Gantt Chart). Unfortunately, I don't possess the skills to be successful at such an endeavor. My attempts have produced the code going through the complete loop for a single criteria then copying that row's specific cells before going to the next criteria and repeating the same process. This unfortunately has resulted in the pasting of the cells out of sequence. This makes it impossible to follow any work that belongs to the same JOB # on the Gantt Chart. I would appreciate any and all assistance on this issue. Thank you.

Sub CopyPaste()

    Dim SourceData As Worksheet
    Dim Dashboard As Worksheet
    Dim searchString As String
    Dim lastSourceRow As Long
    Dim startSourceRow As Long
    Dim lastTargetRow As Long
    Dim sourceRowCounter As Long
    Dim columnToEval As Long
    Dim columnCounter As Long
    Dim columnsToCopy As Variant
    Dim columnsDestination As Variant
    
    Set SourceData = ThisWorkbook.Worksheets("Source Data")
    Set Dashboard = ThisWorkbook.Worksheets("Dashboard")
    
    columnsToCopy = Array(7, 8, 11)
    columnsDestination = Array(2, 3, 4)
    
    searchString = "New"
    startSourceRow = 3
    columnToEval = 45
    
    lastTargetRow = Dashboard.Cells(Dashboard.Rows.Count, 1).End(xlUp).Row 'move this out of the loop
    lastSourceRow = SourceData.Cells(SourceData.Rows.Count, 1).End(xlUp).Row
    
    For sourceRowCounter = startSourceRow To lastSourceRow
        If SourceData.Cells(sourceRowCounter, columnToEval).Value = searchString Then
            
            For columnCounter = 0 To UBound(columnsToCopy)
                Dashboard.Cells(lastTargetRow, columnsDestination(columnCounter)).Offset(1, 0).Value = _
                      SourceData.Cells(sourceRowCounter, columnsToCopy(columnCounter)).Value
            Next columnCounter
            lastTargetRow = lastTargetRow + 1 'next destination row
        End If
    Next sourceRowCounter
    
    SourceData.Activate

End Sub

**protonLeah** · 07-22-2024, 02:24 PM

Sub PublishE()

Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False

    Dim SOURCEDATA As Worksheet
    Dim DASHBOARD As Worksheet
    Dim searchString As String
    Dim SearchItem  As String
    Dim lastSourceRow As Long
    Dim startSourceRow As Long
    Dim lastTargetRow As Long
    Dim sourceRowCounter As Long
    Dim columnToEval As Long
    Dim columnCounter As Long
    Dim columnsToCopy As Variant
    Dim columnsDestination As Variant
    Dim IsMatch
    
    Set SOURCEDATA = ThisWorkbook.Worksheets("Execution Template")
    lastSourceRow = SOURCEDATA.Cells(Rows.Count, 1).End(xlUp).Row
    
    Set DASHBOARD = ThisWorkbook.Worksheets("Test")
    lastTargetRow = DASHBOARD.Cells(Rows.Count, 1).End(xlUp).Row 'move this out of the loop
    
    searchString = "AWENG REVIEW,CHANGE IN WORK SCOPE,FCO REQ'd,PLANNING CP"
    startSourceRow = 3
    columnToEval = 9
    columnsToCopy = Array(2, 4, 5, 7, 18, 19, 19, 27, 28, 28, 33, 34, 34, 45, 46, 46, 51, 60, 65)
    columnsDestination = Array(1, 2, 3, 4, 7, 8, 1304, 9, 10, 1305, 11, 12, 1306, 13, 14, 1307, 17, 19, 5)
    
    For sourceRowCounter = startSourceRow To lastSourceRow
        SearchItem = SOURCEDATA.Cells(sourceRowCounter, columnToEval).Value
        IsMatch = InStr(searchString, SearchItem)
        If SearchItem = "" Or IsMatch > 0 Then
            For columnCounter = 0 To UBound(columnsToCopy)
                DASHBOARD.Cells(lastTargetRow, columnsDestination(columnCounter)).Offset(1, 0).Value = _
                      SOURCEDATA.Cells(sourceRowCounter, columnsToCopy(columnCounter)).Value
            Next columnCounter
            lastTargetRow = lastTargetRow + 1 'next destination row
        End If
    Next sourceRowCounter
    
    SOURCEDATA.Activate
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

**BZ61** · 07-22-2024, 04:41 PM

Thank you for responding. I may be missing something, but when I inserted the corrections, it only copies only the first match and does not continue looping through the column. Your assistance is greatly appreciated.

**kvsrinivasamurthy** · 07-23-2024, 09:48 AM

Try this code. you can make changes in the array in this line. Array i have selected as per your code in the file.

 searchString = Array("", "AWENG REVIEW", "CHANGE IN WORK SCOPE", "FCO REQ'd")

Macro code:

Sub PublishE()

Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False

    Dim SourceData As Worksheet
    Dim Dashboard As Worksheet
    Dim searchString As Variant, SS As Variant
    Dim lastSourceRow As Long
    Dim startSourceRow As Long
    Dim lastTargetRow As Long
    Dim sourceRowCounter As Long
    Dim columnToEval As Long
    Dim columnCounter As Long
    Dim columnsToCopy As Variant
    Dim columnsDestination As Variant
    
    Set SourceData = ThisWorkbook.Worksheets("Execution Template")
    Set Dashboard = ThisWorkbook.Worksheets("Test")
    
    columnsToCopy = Array(2, 4, 5, 7, 18, 19, 19, 27, 28, 28, 33, 34, 34, 45, 46, 46, 51, 60, 65)
    columnsDestination = Array(1, 2, 3, 4, 7, 8, 1304, 9, 10, 1305, 11, 12, 1306, 13, 14, 1307, 17, 19, 5)
    
    '
    searchString = Array("", "AWENG REVIEW", "CHANGE IN WORK SCOPE", "FCO REQ'd")
    startSourceRow = 3
    columnToEval = 9
          
    lastTargetRow = Dashboard.Cells(Dashboard.Rows.Count, 1).End(xlUp).Row 'move this out of the loop
    lastSourceRow = SourceData.Cells(SourceData.Rows.Count, 1).End(xlUp).Row
    
    For Each SS In searchString
    
    For sourceRowCounter = startSourceRow To lastSourceRow
        If SourceData.Cells(sourceRowCounter, columnToEval).Value = SS Then
            
            For columnCounter = 0 To UBound(columnsToCopy)
                Dashboard.Cells(lastTargetRow, columnsDestination(columnCounter)).Offset(1, 0).Value = _
                      SourceData.Cells(sourceRowCounter, columnsToCopy(columnCounter)).Value
            Next columnCounter
            lastTargetRow = lastTargetRow + 1 'next destination row
        End If
    Next sourceRowCounter
    
    Next SS
    
   
    SourceData.Activate
   
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

**BZ61** · 07-23-2024, 11:23 AM

Thank you, but this is performing the same as the previous changes provided by protonLeah. It is quick and copies all of the cells perfectly, but only on the first match of the first criteria then it goes no further and copies no other matches. Sorry for being a pain.

**protonLeah** · 07-23-2024, 04:20 PM

Sub PublishE()
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Dim SOURCEDATA          As Worksheet
    Dim DASHBOARD           As Worksheet
    Dim SearchStringList    As Variant
    Dim TestString          As Variant
    Dim lastSourceRow       As Long
    Dim startSourceRow      As Long
    Dim NextTargetRow       As Long
    Dim sourceRowPointer    As Long
    Dim columnToEval        As Long
    Dim ColumnPointer       As Long
    Dim columnsToCopy       As Variant
    Dim columnsDestination  As Variant
    
    Set SOURCEDATA = ThisWorkbook.Worksheets("Execution Template")
    lastSourceRow = SOURCEDATA.Cells(Rows.Count, 1).End(xlUp).Row
    
    Set DASHBOARD = ThisWorkbook.Worksheets("Test")
    NextTargetRow = DASHBOARD.Cells(Rows.Count, 1).End(xlUp).Row
    
    SearchStringList = Split(",AWENG REVIEW,CHANGE IN WORK SCOPE,FCO REQ'd,PLANNING CP", ",")
    startSourceRow = 3
    columnToEval = 9
    columnsToCopy = Array(2, 4, 5, 7, 18, 19, 19, 27, 28, 28, 33, 34, 34, 45, 46, 46, 51, 60, 65)
    columnsDestination = Array(1, 2, 3, 4, 7, 8, 1304, 9, 10, 1305, 11, 12, 1306, 13, 14, 1307, 17, 19, 5)
    
    For Each TestString In SearchStringList
        For sourceRowPointer = startSourceRow To lastSourceRow
            If SOURCEDATA.Cells(sourceRowPointer, columnToEval).Value = TestString Then
                For ColumnPointer = LBound(columnsToCopy) To UBound(columnsToCopy)
                    DASHBOARD.Cells(NextTargetRow, columnsDestination(ColumnPointer)).Offset(1, 0).Value = _
                              SOURCEDATA.Cells(sourceRowPointer, columnsToCopy(ColumnPointer)).Value
                Next ColumnPointer
                NextTargetRow = NextTargetRow + 1 'next destination row
            End If
        Next sourceRowPointer
    Next TestString
    
    SOURCEDATA.Activate
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

**BZ61** · 07-23-2024, 06:02 PM

Sorry, but it had the same results. It does not seem to go past the 1st criteria match. Thank you for trying.

**kvsrinivasamurthy** · 07-24-2024, 09:45 AM

REF: Post#5
There is no data in EXECUTION TEMPLATE sheet except for the first match in the file. If you are having problem with other file upload file removing sensitive data.

**BZ61** · 07-24-2024, 01:52 PM

Hummmm...I don't have your view on the Execution Template, so I've attached what I see. I've also copied the modified code that I did, and it copies all of the cells in the rows that meet the criteria in column
#9(I). Unfortunately, everything is out of sequence, and this doesn't work for tracking jobs. Please let me know what I can do to help you?

Sub PublishE()
    
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False


    Dim SourceData As Worksheet
    Dim Dashboard As Worksheet
    Dim searchString As Variant
    Dim lastSourceRow As Long
    Dim startSourceRow As Long
    Dim lastTargetRow As Long
    Dim sourceRowCounter As Long
    Dim columnToEval As Long
    Dim columnCounter As Long
    Dim columnsToCopy As Variant
    Dim columnsDestination As Variant
    
    Set SourceData = ThisWorkbook.Worksheets("Execution Template")
    Set Dashboard = ThisWorkbook.Worksheets("Test")
    
    columnsToCopy = Array(2, 4, 5, 7, 18, 19, 19, 27, 28, 28, 33, 34, 34, 45, 46, 46, 51, 60, 65)
    columnsDestination = Array(1, 2, 3, 4, 7, 8, 1304, 9, 10, 1305, 11, 12, 1306, 13, 14, 1307, 17, 19, 5)
    
    searchString = ""
    startSourceRow = 3
    columnToEval = 9
          
    lastTargetRow = Dashboard.Cells(Dashboard.Rows.Count, 1).End(xlUp).Row 'move this out of the loop
    lastSourceRow = SourceData.Cells(SourceData.Rows.Count, 1).End(xlUp).Row
    
    For sourceRowCounter = startSourceRow To lastSourceRow
        If SourceData.Cells(sourceRowCounter, columnToEval).Value = searchString Then
            
            For columnCounter = 0 To UBound(columnsToCopy)
                Dashboard.Cells(lastTargetRow, columnsDestination(columnCounter)).Offset(1, 0).Value = _
                      SourceData.Cells(sourceRowCounter, columnsToCopy(columnCounter)).Value
            Next columnCounter
            lastTargetRow = lastTargetRow + 1 'next destination row
        End If
    Next sourceRowCounter
    
    searchString = "AWENG REVIEW"
    startSourceRow = 3
    columnToEval = 9
          
    lastTargetRow = Dashboard.Cells(Dashboard.Rows.Count, 1).End(xlUp).Row 'move this out of the loop
    lastSourceRow = SourceData.Cells(SourceData.Rows.Count, 1).End(xlUp).Row
    
    For sourceRowCounter = startSourceRow To lastSourceRow
        If SourceData.Cells(sourceRowCounter, columnToEval).Value = searchString Then
            
            For columnCounter = 0 To UBound(columnsToCopy)
                Dashboard.Cells(lastTargetRow, columnsDestination(columnCounter)).Offset(1, 0).Value = _
                      SourceData.Cells(sourceRowCounter, columnsToCopy(columnCounter)).Value
            Next columnCounter
            lastTargetRow = lastTargetRow + 1 'next destination row
        End If
    Next sourceRowCounter
    
     searchString = "CHANGE IN WORK SCOPE"
    startSourceRow = 3
    columnToEval = 9
          
    lastTargetRow = Dashboard.Cells(Dashboard.Rows.Count, 1).End(xlUp).Row 'move this out of the loop
    lastSourceRow = SourceData.Cells(SourceData.Rows.Count, 1).End(xlUp).Row
    
    For sourceRowCounter = startSourceRow To lastSourceRow
        If SourceData.Cells(sourceRowCounter, columnToEval).Value = searchString Then
            
            For columnCounter = 0 To UBound(columnsToCopy)
                Dashboard.Cells(lastTargetRow, columnsDestination(columnCounter)).Offset(1, 0).Value = _
                      SourceData.Cells(sourceRowCounter, columnsToCopy(columnCounter)).Value
            Next columnCounter
            lastTargetRow = lastTargetRow + 1 'next destination row
        End If
    Next sourceRowCounter
    
     searchString = "FCO REQ'd"
    startSourceRow = 3
    columnToEval = 9
          
    lastTargetRow = Dashboard.Cells(Dashboard.Rows.Count, 1).End(xlUp).Row 'move this out of the loop
    lastSourceRow = SourceData.Cells(SourceData.Rows.Count, 1).End(xlUp).Row
    
    For sourceRowCounter = startSourceRow To lastSourceRow
        If SourceData.Cells(sourceRowCounter, columnToEval).Value = searchString Then
            
            For columnCounter = 0 To UBound(columnsToCopy)
                Dashboard.Cells(lastTargetRow, columnsDestination(columnCounter)).Offset(1, 0).Value = _
                      SourceData.Cells(sourceRowCounter, columnsToCopy(columnCounter)).Value
            Next columnCounter
            lastTargetRow = lastTargetRow + 1 'next destination row
        End If
    Next sourceRowCounter
    
     searchString = "PLANNING CP"
    startSourceRow = 3
    columnToEval = 9
          
    lastTargetRow = Dashboard.Cells(Dashboard.Rows.Count, 1).End(xlUp).Row 'move this out of the loop
    lastSourceRow = SourceData.Cells(SourceData.Rows.Count, 1).End(xlUp).Row
    
    For sourceRowCounter = startSourceRow To lastSourceRow
        If SourceData.Cells(sourceRowCounter, columnToEval).Value = searchString Then
            
            For columnCounter = 0 To UBound(columnsToCopy)
                Dashboard.Cells(lastTargetRow, columnsDestination(columnCounter)).Offset(1, 0).Value = _
                      SourceData.Cells(sourceRowCounter, columnsToCopy(columnCounter)).Value
            Next columnCounter
            lastTargetRow = lastTargetRow + 1 'next destination row
        End If
    Next sourceRowCounter
    
    SourceData.Activate
   
End If

Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

Coding works for single criteria, but how would you modify it for several criteria?

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Coding works for single criteria, but how would you modify it for several criteria?

Re: Coding works for single criteria, but how would you modify it for several criteria?

Re: Coding works for single criteria, but how would you modify it for several criteria?

Re: Coding works for single criteria, but how would you modify it for several criteria?

Re: Coding works for single criteria, but how would you modify it for several criteria?

Re: Coding works for single criteria, but how would you modify it for several criteria?

Re: Coding works for single criteria, but how would you modify it for several criteria?

Re: Coding works for single criteria, but how would you modify it for several criteria?

Re: Coding works for single criteria, but how would you modify it for several criteria?

Thread Information

Users Browsing this Thread

Similar Threads

Coding works for WORD but not POWERPOINT, how should i modify it?

Single Criteria Index Match with concatenated criteria NOT WORKING

Countifs with multiple criteria in single criteria range

Countifs with multiple criteria in single criteria range

To modify macro based on criteria in input sheet to lookup on criteria then extract data

[SOLVED] Counting cells that meet multiple single criteria as variable criteria

Return dates that match a single criteria (a countif criteria)

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions