Combining 2 separate codes into one

julhs

Active Member
Joined
Dec 3, 2018
Messages
407
Office Version
  1. 2010
Platform
  1. Windows
Due to my limited skills with VBA I have to resort to solving individual elements of my FINAL code.
This maybe a potentially floored method, but not much different than using “Record Macro” for hints.
Yet again I’m looking for help to combine two separate WORKING codes into ONE.
Had a lot of help with the separate aspects of the different elements.
I know where the problem lies but I can’t resolve it.

Code doesn’t bug out, it just fails/doesn’t complete the copying/pasting stage.
Because as code stands it is not passing the ACTUAL USED RANGE ($S$10:$S$337) from the first section of code to the second.
VBA Code:
Sub juhls4_plus2Combined_A2()
Dim sht As Worksheet
Dim lastcell As Range, firstcell As Range
Dim lastRow As Long, firstRow As Long
Dim findString As String
Dim LstUsedRow As Variant
Dim FstUsedCell  As Variant

Dim Usedcells As Long  ' Range Long Variant Integer
Dim Frow As Long, Lrow As Long, DestRow As Long, i As Integer
Dim rng As Range, r As Range
Dim copyCells As Range, pasteRng As Range        
                                        'Application.ScreenUpdating = False  ' re-apply when testing complete
    Set sht = ThisWorkbook.ActiveSheet
            ' This is to clear the Destination range before a new paste
            '  it first finds the row beneath target row with "Cash Paid" in column T
        Frow = sht.Range("T:T").Find(what:="Cash Paid", LookIn:=xlValues, LookAt:=xlWhole).Row
            'This finds the ACTUAL last row based on column T
        Lrow = sht.Cells(sht.Rows.Count, "T").End(xlUp).Row
        sht.Range("ar" & Frow + 1 & ":AT" & Lrow).Clear '  Is the Results/Destination area/range to clear
 
      On Error Resume Next
'#######################################################################
          'This section returns the "ACTUAL USED RANGE" of column S (Curtesy of Alex Blakenburg)
Set sht = ActiveSheet
     With sht
        ' Get start of Data Range
        findString = "Bank & Cash"
           Set firstcell = .Range("S:S").Find(what:=findString, LookIn:=xlValues, LookAt:=xlWhole)
        If firstcell Is Nothing Then Exit Sub
       
        firstRow = firstcell.End(xlDown).Row
       
        ' Get end of Data Range
        findString = "Cash Paid"
           Set lastcell = .Range("T:T").Find(what:=findString, LookIn:=xlValues, LookAt:=xlWhole)
         If lastcell Is Nothing Then Exit Sub
       
           Set lastcell = lastcell.Offset(, -1)        ' Move across to amount column
         If lastcell.Offset(-1) <> "" Then
            Set lastcell = lastcell.Offset(-1)
        Else
            Set lastcell = lastcell.End(xlUp)
        End If
       
        lastRow = lastcell.Row
           'Usedcells = Range("s" & firstRow & i & ":s" & lastRow & i)
        Range("aq340") = Range("s" & firstRow & ":s" & lastRow).Address  'Puts "ACTUAL USED RANGE" into a cell on sheet
    'End With
'#######################################################################
' 'For testing purposes
       Debug.Print "First Row: " & firstRow
       Debug.Print "Last Row: " & lastRow
       Debug.Print "Used range: " & Range("S" & firstRow & ":S" & lastRow).Address
       Debug.Print "copyCells: " & copyCells
       Debug.Print "DestRow:" & DestRow
       Debug.Print "Frow: " & Frow
       Debug.Print "Lrow: " & Lrow
'***********************************************************************
'           ######   This is section I'm failing to pass the "ACTUAL USED RANGE" from above, to 
  Set copyCells = Range("S7") 'cell with CF rules to copy
  Set pasteRng = rng
        If copyCells Is Nothing Then Exit Sub
        If rng Is Nothing Then Exit Sub
        On Error GoTo 0

    For Each r In rng
    r.Interior.Color = r.DisplayFormat.Interior.Color '
  Next r
    rng.FormatConditions.Delete

   Set rng = sht.Range("t:t").Find(what:="Cash Paid", LookIn:=xlValues, LookAt:=xlWhole)
        Lrow = sht.Cells(sht.Rows.Count, "T").End(xlUp).Row
        Lrow = rng.Row
                
        DestRow = sht.Range("T:T").Find(what:="Cash Paid", LookIn:=xlValues, LookAt:=xlWhole).Row  'Locates LAST row of Input Section to paste copied cells to
              For i = 9 To Lrow                                        ' Is the start row to copy FROM
      Set rng = Range("s" & firstRow & i & ":s" & lastRow & i) ' Col# that looking for "Comments" in
            'Set rng = Usedcells     ' Range("S" & i)          ' Col# that looking for "Comments" in
    If Not rng.comment Is Nothing Then
'***********************************************************************
        sht.Range("P" & i).Copy                             ' Corresponding Inv#
        sht.Range("AR" & DestRow + 1).PasteSpecial xlPasteAll
        sht.Range("R" & i & ":S" & i).Copy     'Payment details List & Bank Col
        sht.Range("AS" & DestRow + 1 & ":AT" & DestRow + 1).PasteSpecial xlPasteAll 'Destination for copied cell
    
          DestRow = DestRow + 1
    End If
        Next
          copyCells.Copy
            pasteRng.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
          sht.Range("AR" & Frow - 1).Offset(1, 0).Select
                 'Application.ScreenUpdating = True    ' re-apply when testing complete   
     End With
 End Sub
VBA Code:
Results of Debug.Print
First Row: 10
Last Row: 337
ACTUAL USED RANGE: $S$10:$S$337
DestRow:0
Frow: 342
Lrow: 575
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

Forum statistics

Threads
1,215,030
Messages
6,122,762
Members
449,095
Latest member
m_smith_solihull

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