New problem - FinalRow based on two criteria?

[Mr_Ragweed2]

Hello and thanks for reading this! (I apologize for length, but want to be thorough so you don't have to try and read my mind. Good question = good answer right?)
The code below works the first time through, but the code will be ran multiple times. It's a two step copy and paste based on other variables.
Below i have attached screenshots to show current and desired outcomes. I'm guessing the problem is in my "ThisFinal" (FinalRow) statement of the code.
When i have it set to ThisFinal = OSumWS.Cells(Rows.Count, 2).End(xlUp).Row it works great at looking at column B.
When i have it set to ThisFinal = OSumWS.Cells(Rows.Count, 17).End(xlUp).Row it works great at looking at Column Q.

It needs to look at both.

My code is at the bottom. - Don't laugh, i'm a novice who tries to adapt everything i see in the posts here.

Outcome on running it the first time:

Current outcome when i run it twice:

Desired outcome when i run it twice:

Sheets("Dekalb Seed Order Form").Select

 'does this find the next empty row? NO IT DOES NOT. It only looks for data in column B and does not account for column Q
 ' and when i set ThisFinal to 17 (Q) it does not account for column 2 (B)
 
    Dim ThisFinal As Long
    Dim i As Integer
    Dim OSumWS As Worksheet
    Dim DekalbWS As Worksheet

    Set OSumWS = Sheets("Order Summary")
    Set DekalbWS = Sheets("Dekalb Seed Order Form")
    
    For i = 19 To 31
        ThisFinal = OSumWS.Cells(Rows.Count, 2).End(xlUp).Row
        
        If DekalbWS.Cells(i, 3).Value <> "" Then
            With Application.Intersect(DekalbWS.Rows(i).EntireRow, DekalbWS.Range("C:U"))
                .UnMerge
                .Copy
            End With
    
            OSumWS.Cells(ThisFinal + 1, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    Next i
    OSumWS.UsedRange.Columns.AutoFit
    Sheets("Dekalb Seed Order Form").Activate
    '----------------------------------------------------------------------------------------
    'below this line needs relocate to next available row after all product rows have been copied - works
               
     Dim copyRange1 As Range
     Dim copyRange2 As Range
     Dim copyRange3 As Range
     Dim copyRange4 As Range
     
     Dim cel As Range
     Dim pasteRange1 As Range
     Dim pasteRange2 As Range
     Dim pasteRange3 As Range
     Dim pasteRange4 As Range
     
     Dim FinalColumn As Long
     
     Set copyRange1 = Sheets("Dekalb Seed Order Form").Range("T39")
     Set copyRange2 = Sheets("Dekalb Seed Order Form").Range("T47")
     Set copyRange3 = Sheets("Dekalb Seed Order Form").Range("T57")
     Set copyRange4 = Sheets("Dekalb Seed Order Form").Range("N61")
     
     Set pasteRange1 = Sheets("Order Summary").Cells(ThisFinal + 1, 1)
     Set pasteRange2 = Sheets("Order Summary").Cells(ThisFinal + 1, 1)
     Set pasteRange3 = Sheets("Order Summary").Cells(ThisFinal + 1, 1)
     Set pasteRange4 = Sheets("Order Summary").Cells(ThisFinal + 1, 1)
 
     For Each cel In copyRange1
       cel.Copy
        FinalColumn = Sheets("Order Summary").Cells(1, Columns.Count).End(xlToLeft).Offset(1, -6).Column
        pasteRange1.Cells(1, FinalColumn).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
     Next
     
     For Each cel In copyRange2
       cel.Copy
        FinalColumn = Sheets("Order Summary").Cells(1, Columns.Count).End(xlToLeft).Offset(1, -5).Column
        pasteRange2.Cells(1, FinalColumn).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      Next
      
      For Each cel In copyRange3
       cel.Copy
        FinalColumn = Sheets("Order Summary").Cells(1, Columns.Count).End(xlToLeft).Offset(1, -4).Column
        pasteRange3.Cells(1, FinalColumn).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      Next
      
       For Each cel In copyRange4
       cel.Copy
        FinalColumn = Sheets("Order Summary").Cells(1, Columns.Count).End(xlToLeft).Offset(1, -3).Column
        pasteRange4.Cells(1, FinalColumn).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      Next
      
        Application.CutCopyMode = False
    
    End If

 

[johnnyL]

Quick answer is to replace:

    For i = 19 To 31
        ThisFinal = OSumWS.Cells(Rows.Count, 2).End(xlUp).Row
       
        If DekalbWS.Cells(i, 3).Value <> "" Then
            With Application.Intersect(DekalbWS.Rows(i).EntireRow, DekalbWS.Range("C:U"))
                .UnMerge
                .Copy
            End With
   
            OSumWS.Cells(ThisFinal + 1, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    Next i

with:

    ThisFinal = OSumWS.Cells(Rows.Count, 17).End(xlUp).Row                                  ' Get LastRow of column Q of OSumWS
'
    For i = 19 To 31                                                                        ' Loop through rows 19 thru 31 of DekalbWS
        If DekalbWS.Cells(i, 3).Value <> "" Then                                            '   If column C starting at row 19 of DekalbWS is not blank then ...
            With Application.Intersect(DekalbWS.Rows(i).EntireRow, DekalbWS.Range("C:U"))
                .UnMerge
                .Copy
            End With
'
            OSumWS.Cells(ThisFinal + 1, 2).PasteSpecial Paste:=xlPasteValues, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False                  '       Paste Copied data to LastRow + 1 of column B of OSumWS
'
            ThisFinal = OSumWS.Cells(Rows.Count, 2).End(xlUp).Row                           '       Get LastRow of column B of OSumWS
        End If
    Next i                                                                                  ' Loop back

Longer answer, and I mean shorter cleaner code, would be to clean up your code.

 

[Mr_Ragweed2]

I will give this a try.
I rarely do this. I'm sure to a regular VBA person my code is atrocious. hahaha
Thank you very much. I will reply with the results good or bad and be sure to mark it as a solution when it works.
I am truly very grateful.

 

[johnnyL]

Let us know either way.

 

[Mr_Ragweed2]

Worked perfectly. Thank you very much.
I promise i will work on trying to clean up my code.
Many many thanks!!!!!

 

[johnnyL]

Glad to help. I will try to post a cleaned up version after I get some sleep.

 

[johnnyL]

Here is a shorter version:

    Dim ThisFinal       As Long
    Dim i               As Long
    Dim cel             As Range
    Dim RangeToCopy     As Range, RangeToPaste  As Range
    Dim DekalbWS        As Worksheet, OSumWS    As Worksheet

    Set OSumWS = Sheets("Order Summary")
         Set DekalbWS = Sheets("Dekalb Seed Order Form")
'
    ThisFinal = OSumWS.Cells(Rows.Count, 17).End(xlUp).Row                                      ' Get LastRow of column Q of OSumWS
'
    For i = 19 To 31                                                                            '
        If DekalbWS.Cells(i, 3).Value <> "" Then                                                '
            With Application.Intersect(DekalbWS.Rows(i).EntireRow, DekalbWS.Range("C:U"))       '
                .UnMerge
                .Copy
            End With
'
            OSumWS.Cells(ThisFinal + 1, 2).PasteSpecial Paste:=xlPasteValues, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False                      '
'
            ThisFinal = OSumWS.Cells(Rows.Count, 2).End(xlUp).Row                               '       Get LastRow of column B of OSumWS
        End If
    Next                                                                                        '
'
    With DekalbWS
        Set RangeToCopy = Union(.Range("T39"), .Range("T47"), .Range("T57"), .Range("N61"))     '   Load non contiguous cells into RangeToCopy
    End With
'
    Set RangeToPaste = OSumWS.Range("N" & ThisFinal + 1)                                        ' Set RangeToPaste to N & Last row + 1
'
    For Each cel In RangeToCopy.Areas                                                           ' Loop through each address in RangeToCopy
        RangeToPaste = cel                                                                      '   Copy/paste the value
'
        Set RangeToPaste = RangeToPaste.Offset(, 1)                                             '   Increment the column to paste to
    Next
'
    OSumWS.UsedRange.Columns.AutoFit                                                             '
    Application.CutCopyMode = False

 

[Mr_Ragweed2]

Thank you! i will give this a try and let you know either way.

 

[johnnyL]

Thank you. Any questions please ask.