Macro to copy I need a macro that will look on sheet1 and copy the values to the next blank row in sheet2 starting at a specific cell.

[onlibo]

Hi,

This will be an easy one for you folks, but I am a novice in VBA.

Starting in row 9 of sheet1, if there is a value in b9, copy the values in cells b9, c9, d9, g1 and g2 and paste special the values in the same order into the next blank row in sheet2 starting at cell a14. Continue this copy/pasting of data for all rows in sheet1 if there is data in column b for the range b9 through b15. The data copied from cells g1 and g2 will need the same for each record like $g$1 and $g$2$ in a standard formula.

Thanks in Advance for any help you folks can offer,

Scott

 

[Momentman]

So for example row 10 of sheet 1 meets the criteria, then B10,C10,D10,G1,G2 are copied to A14,B14,C14,D14,E14 and the next row that meets the criteria is copied same way to row 15 of sheet2, is that right?

 

[onlibo]

Yep..exactly. Thanks for the speedy response.

 

[Momentman]

Please create a copy of the workbook and try this macro on a copy

Sub copymacro()    Dim wks As Worksheet
    Dim wks2 As Worksheet
    
    Set wks = Worksheets("sheet1")
    Set wks2 = Worksheets("sheet2")
    
    lastrow = wks.Range("A9").End(xlDown).Row
    lastrow2 = 14
    
    For i = 9 To lastrow
        
        If wks.Range("B" & i).Value <> "" Then
            wks.Range("B" & i & ":" & "D" & i).Copy
            wks2.Activate
            wks2.Range("A" & lastrow2).Select
            ActiveSheet.Paste
            
            wks.Activate
            wks.Range("G1:G2").Select
            Selection.Copy
            wks2.Activate
            wks2.Range("D" & lastrow2).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
            
            lastrow2 = lastrow2 + 1
        End If
        
        
    Next i
        
    
End Sub

 

[onlibo]

Hi,

That works great! Thanks very much. The only problem is if I run the macro a second time, the data pastes over the existing data in sheet2. Could you please offer a modification to ensure that if there is data in the target cell in sheet2, it will then move down 1 row until the next empty row is available and then paste special?

Best,

Scott

 

[Momentman]

I initially made it dynamic but because you wanted it to start from A14, I had to keep the way I did, lets see how we can it to work. Does this meet your request?

Sub copymacro()    Dim wks As Worksheet
    Dim wks2 As Worksheet
    
    Set wks = Worksheets("sheet1")
    Set wks2 = Worksheets("sheet2")
    
    lastrow = wks.Range("A9").End(xlDown).Row
    
    lastrow2a = 14
    lastrow2b = wks2.Range("A65536").End(xlUp).Row + 1
    
    If lastrow2b < lastrow2a Then
        lastrow2 = lastrow2a
    ElseIf lastrow2b > lastrow2a Then
        lastrow2 = lastrow2b
    End If
    
    For i = 9 To lastrow
        
        If wks.Range("B" & i).Value <> "" Then
            wks.Range("B" & i & ":" & "D" & i).Copy
            wks2.Activate
            wks2.Range("A" & lastrow2).Select
            ActiveSheet.Paste
            
            wks.Activate
            wks.Range("G1:G2").Select
            Selection.Copy
            wks2.Activate
            wks2.Range("D" & lastrow2).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
            
            lastrow2 = lastrow2 + 1
        End If
        
        
    Next i
        
    
End Sub

 

[JLGWhiz]

Change this line of code:

lastrow2 = 14

To this;

If wks2.Range("A14") = "" Then
    lastrow2 = 14
Else
    lastrow2 = wks2.Cells(Rows.Count, 1).End(xlUp)(2)
End If

 

[onlibo]

I tried it, but it errored out. Here is the code as it exists in my workbook:

Sub copymacro()
Dim wks As Worksheet
Dim wks2 As Worksheet

Set wks = Worksheets("sheet1")
Set wks2 = Worksheets("sheet2")

lastrow = wks.Range("A9").End(xlDown).Row
If wks2.Range("A14") = "" Then
lastrow2 = 14
Else
lastrow2 = wks2.Cells(Rows.Count, 1).End(xlUp)(2)
End If

For i = 9 To lastrow

If wks.Range("B" & i).Value <> "" Then
wks.Range("B" & i & ":" & "D" & i).Copy
wks2.Activate
wks2.Range("A" & lastrow2).Select
ActiveSheet.Paste

wks.Activate
wks.Range("G1:G2").Select
Selection.Copy
wks2.Activate
wks2.Range("D" & lastrow2).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

lastrow2 = lastrow2 + 1
End If


Next i

 

[Momentman]

have you tried the modified one I sent?

 

[onlibo]

I apologize. I missed that middle post with the modified code. This one works as expected now. Excellent! I appreciate your help very much.

Thank you!