VBA Code to Copy and Paste

[Colmans]

I'm trying to work on some code that will

1. allow me to find things in worksheet1 which are "sold",
2. copy the three cells immediately to the right of that cell
3. Insert copied cells into worksheet2 but starting at a specific point
4. Copied cells must be copied as text/value as the cells contain formula

The "Sold" status will only be in one column (L)

I managed at one point to copy some over but I only got the formulas, but now I'm getting errors and I'm lost

Any help would be greatly appreciated

Sub CommandButton1_Click()

Dim C As Range
Dim rngCopyRange As Range
Dim FirstAddress As String
Dim shtSheet1 As Worksheet
Dim shtSheet2 As Worksheet
Dim lngSheet2LastRow As Long

' Find All Values And Copy the three Cells To the
' right To sheet 2 at a specific point in the second worksheet

End Sub

Public Sub FindSettledinQtr()
Set shtSheet1 = Sheets("Vehicle Data")
Set shtSheet2 = Sheets("Statement")

' Assume Column L Always Has Data

lngSheet2LastRow = shtSheet2.Cells(Rows.Count, "L").End(xlUp).Row
With shtSheet1.Range("A1:P999")
    Set C = .Find("Paid", LookIn:=xlValues)
    If Not C Is Nothing Then
        FirstAddress = C.Address
        Call CopyData
        Set C = .FindNext(C)
        Do While Not C Is Nothing And C.Address <> FirstAddress
            Call CopyData
            Set C = .FindNext(C)
        Loop
    
End If

End With

End Sub

Public Sub CopyData()
lngSheet2LastRow = lngSheet2LastRow + 1
Set rngCopyRange = Range(C, C.Offset(0, 3))
rngCopyRange.Copy shtSheet2.Cells(lngSheet2LastRow, 1)

End Sub

 

[alansidman]

Here is some code I developed based upon your explanation.
Notes: Change Sheet names as appropriate
Assumed paste to first row available on sheet2 column A. Change as needed.

Option Explicit


Sub ams()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
Dim lr As Long
lr = s1.Range("L" & Rows.Count).End(xlUp).Row
Dim r2 As Long, i As Long
Application.ScreenUpdating = False
For i = 1 To lr
r2 = s2.Range("A" & Rows.Count).End(xlUp).Row
If s1.Range("L" & i) = "Sold" Then
s1.Range("M" & i & ":O" & i).Copy
s2.Range("A" & r2 + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed"


End Sub

 

[alansidman]

Forgot to add two lines of code. See amended code below

Sub ams()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
Dim lr As Long
lr = s1.Range("L" & Rows.Count).End(xlUp).Row
Dim r2 As Long, i As Long
Application.ScreenUpdating = False
For i = 1 To lr
r2 = s2.Range("A" & Rows.Count).End(xlUp).Row
If s1.Range("L" & i) = "Sold" Then
s1.Range("M" & i & ":O" & i).Copy
s2.Range("A" & r2 + 1).PasteSpecial xlPasteValues
End if
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed"




End Sub

 

[Colmans]

Forgot to add two lines of code. See amended code below

Sub ams()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
Dim lr As Long
lr = s1.Range("L" & Rows.Count).End(xlUp).Row
Dim r2 As Long, i As Long
Application.ScreenUpdating = False
For i = 1 To lr
r2 = s2.Range("A" & Rows.Count).End(xlUp).Row
If s1.Range("L" & i) = "Sold" Then
s1.Range("M" & i & ":O" & i).Copy
s2.Range("A" & r2 + 1).PasteSpecial xlPasteValues
End if
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed"




End Sub

Alan

Thanks for your help. I'm getting the Completed box appear but nothing is being copied over. I have changed the target cell to "A" & r32 as this is where I need the text inserted.

 

[Colmans]

Ignore previous - It was my spelling error. It now copies. I changed "A" & r32 back to r2 as well.

However, the code seems to insert the text underneath the last line of text in Column A and not at a specific place. Imagine that I have in A20 "Balance At start", and in A21 I have "Balace at End", I'd like to be able to insert the copied data below A20, so that A21 drops down so that it is the last row.

 

[alansidman]

Try this amended code

Option Explicit


Sub ams()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
Dim lr As Long
lr = s1.Range("L" & Rows.Count).End(xlUp).Row
Dim r2 As Long, i As Long
Application.ScreenUpdating = False
For i = 1 To lr
r2 = s2.Range("A" & Rows.Count).End(xlUp).Row
If s1.Range("L" & i) = "Sold" Then
s1.Range("M" & i & ":O" & i).Copy
s2.Range("A21").EntireRow.Insert
s2.Range("A21").PasteSpecial xlPasteValues
's2.Range("A" & r2 + 1).PasteSpecial xlPasteValues
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed"




End Sub

 

[Colmans]

Alan

Thanks for your help so far, its been really helpfull. I've expanded my macro now to include a couple of tweeks, but have three issues.

1. Once I have copied the data from my spreadsheet, I want to insert a value from B11 (its a date) into the cell in Column A that is the last empty cell in that range. I can select the cell but when I run a select copy function for B11 it does not work. it inserts blank cells above the lines copied over.

2. when the copy B11 code did copy, it copied the cell format including the box outline when I just want it to copy the cell value.

3. If I run the macro and there is no data to copy from the other worksheet (a possibility) my code to select the highest empty row does not work. I still need this as I will always need to copy the date from B11 into A as the last part of my macro.

Any help would be greatly appreciated.

Private Sub CommandButton1_Click()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Vehicle Data")
Set s2 = Sheets("Statement")
Dim lr As Long
QtrEnd = Range("B11")

' Clear contents on statement

    Range("A29:C46").Select
    Selection.ClearContents

' SortColumn M on Data Sheet

    Sheets("Vehicle Data").Select
    ActiveWorkbook.Worksheets("Vehicle Data").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Vehicle Data").AutoFilter.Sort.SortFields.Add Key _
        :=Range("M1:M22"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Vehicle Data").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    Sheets("Statement").Select
    End With
    
' Select and Paste Settlement Details

lr = s1.Range("L" & Rows.Count).End(xlUp).Row
Dim r2 As Long, i As Long
Application.ScreenUpdating = False
For i = 1 To lr
r2 = s2.Range("A" & Rows.Count).End(xlUp).Row
If s1.Range("L" & i) = "Settled In Qtr" Then
s1.Range("M" & i & ":O" & i).Copy
s2.Range("A" & r2 + 1).PasteSpecial xlPasteValues
Range("A999").End(xlUp).Offset(1, 0).Select

' Now copy contents of "B11" into the selected cell

End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed"

End Sub