New problem - FinalRow based on two criteria?

Mr_Ragweed2

Board Regular
Joined
Nov 11, 2022
Messages
145
Office Version
  1. 365
Platform
  1. Windows
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:
run once.jpg


Current outcome when i run it twice:
Current outcome.jpg


Desired outcome when i run it twice:
desired outcome.jpg



VBA Code:
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
 

Attachments

  • run once.jpg
    run once.jpg
    43.6 KB · Views: 8

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
Quick answer is to replace:
VBA Code:
    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:

VBA Code:
    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.
 
Upvote 0
Solution
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.
 
Upvote 0
Worked perfectly. Thank you very much.
I promise i will work on trying to clean up my code. :)
Many many thanks!!!!!
 
Upvote 0
Glad to help. I will try to post a cleaned up version after I get some sleep.
 
Upvote 0
Here is a shorter version:

VBA Code:
    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
 
Upvote 0

Forum statistics

Threads
1,223,098
Messages
6,170,100
Members
452,301
Latest member
QualityAssurance

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