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.
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