Major vba help needed please

[saxby146]

B	C	D	E	F	G	H	I	J
Contact details	E-mail	Activity	Quantity	Caters For per hour	Cost	Charge	Profit	Item Subtotal
Pam TEL: 07979 865526		Air Rifles		15 p/h	£260.00	£400.00	£140.00	£0
		Archery		15 p/h	£260.00	£400.00	£140.00	£0

<tbody>
</tbody>

I have a work book with 2 pages. Sheet 1(Quote Calculator) and sheet 2 (Quote)
I need to copy and paste columns D,E,H,J from the quote calculator sheet to the quote sheet with the use of a macro? however I need it to only paste when there is a value in the quantity column. The some of the cells to be copied have their own formula in them too. I hope this makes sense.
Thanks
Dan

 

[My Aswer Is This]

Try this:

Sub Quote()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Dim Lastrowa As Long
Lastrow = Sheets("Quote Calculator").Cells(Rows.Count, "E").End(xlUp).Row
Lastrowa = Sheets("Quote").Cells(Rows.Count, "A").End(xlUp).Row + 1
    For i = 1 To Lastrow
        If Cells(i, "E").Value <> "" Then
            Application.Union(Cells(i, 4), Cells(i, 5), Cells(i, 8), Cells(i, 10)).Copy Destination:=Sheets("Quote").Range("A" & Lastrowa)
            Lastrowa = Lastrowa + 1
         End If
    Next
Application.ScreenUpdating = True
End Sub

 

[saxby146]

Thanks. It wouldn't work though.
this is what I have at the min.
it just copies all cells across though.

I need to be able to isolate the required columns from quote calculator and if there is a figure in the quantity column then the vba transfers to the other page.
Sub Quote()
'
' Quote Macro
'
' Keyboard Shortcut: Ctrl+q
'
Sheets("Quote Calculator").Range("A1:J114").AdvancedFilter Action:= _
xlFilterCopy, CriteriaRange:=Sheets("Quote Calculator").Range("M1:M2"), _
CopyToRange:=Range("Sheet1!Extract"), Unique:=False
End Sub

 

[My Aswer Is This]

You should explain what you mean when you say it does not work. The script looks in column "E" and if there is a value in column "E" it copies that row to the other sheet.

If you already have a way you want it done why do you need me?

 

[saxby146]

ADVERTISEMENT

sorry. it copies over but all the columns are wrong? its my mistake as i've just noticed my sheets aren't set up the same!! I'm gonna build a new sheet and start again..i have literally no idea what I'm doing!
The one I'm using, I'm just making do as I cant figure the rest out.
I need it to look through column E on quote calculator and if there is a number, copy the row but only columns DEH&J to the new sheet and paste them into columns ABC&D which i've no idea how to do.
apologies didn't mean to be awkward.

 

[My Aswer Is This]

The script I sent you does just what you asked it does not copy over the wrong columns. You said copy over columns D,E,H,J
I test my scripts and know what they do.

Your quote:
"I need to copy and paste columns D,E,H,J"

Get back with us when you figure out what you want.

 

[JLGWhiz]

ADVERTISEMENT

See if this will work for you

Sub copyStuff()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, rng As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
    For Each c In sh1.Range("E2", sh1.Cells(Rows.Count, 5).End(xlUp))
        If IsNumeric(c.Value) And c.Value > 0 Then
            With sh1
                Set rng = Union(.Cells(c.Row, 4), .Cells(c.Row, 5), .Cells(c.Row, 8), .Cells(c.Row, 10))
            End With
            rng.Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
End Sub

 

[JLGWhiz]

Assume sheet 1 is the quote calculator and sheet 2 is the quote. Forgot about the formulas, use this one.

Sub copyStuff()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, rng As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
    For Each c In sh1.Range("E2", sh1.Cells(Rows.Count, 5).End(xlUp))
        If IsNumeric(c.Value) And c.Value > 0 Then
            With sh1
                Set rng = Union(.Cells(c.Row, 4), .Cells(c.Row, 5), .Cells(c.Row, 8), .Cells(c.Row, 10))
            End With
            rng.Copy
            sh2.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
        End If
    Next
End Sub

 

[My Aswer Is This]

Your script does exactly the same as the one I provided. I run ran both of them.

See if this will work for you

Sub copyStuff()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, rng As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
    For Each c In sh1.Range("E2", sh1.Cells(Rows.Count, 5).End(xlUp))
        If IsNumeric(c.Value) And c.Value > 0 Then
            With sh1
                Set rng = Union(.Cells(c.Row, 4), .Cells(c.Row, 5), .Cells(c.Row, 8), .Cells(c.Row, 10))
            End With
            rng.Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
End Sub

 

[JLGWhiz]

Your script does exactly the same as the one I provided. I run ran both of them.

@My Aswer Is This - My revised code does not do the same thing, I used the correct column for comparison in it.