PDA

View Full Version : Copy a range to another workbook



i_malc
05-30-2013, 02:33 PM
I'm trying to copy a range of cells [if a cell is grater than 0] to the next blank range of cell in another workbook then repeat for ten times.
I've started my code but know there must be an easier way to loop!
Can anyone help?



Workbooks.Open Filename:="C:\Users\xxx\Documents\excel\Book3.xls"
Workbooks("Book3.xls").Activate

If Sheet1.Range("c3") > 0 Then
ThisWorkbook.Worksheets("Sheet1").Range("c3:g3").Copy
Workbooks("Book2.xls").Worksheets("Sheet1").Range("c3:g3").PasteSpecial Paste:=xlPasteValues

If Sheet1.Range("c4") > 0 Then
ThisWorkbook.Worksheets("Sheet1").Range("c4:g4").Copy
Workbooks("Book2.xls").Worksheets("Sheet1").Range("c4:g4").PasteSpecial Paste:=xlPasteValues

If Sheet1.Range("c5") > 0 Then
ThisWorkbook.Worksheets("Sheet1").Range("c5:g5").Copy
Workbooks("Book2.xls").Worksheets("Sheet1").Range("c5:g5").PasteSpecial Paste:=xlPasteValues

If Sheet1.Range("c6") > 0 Then
ThisWorkbook.Worksheets("Sheet1").Range("c6:g6").Copy
Workbooks("Book2.xls").Worksheets("Sheet1").Range("c6:g6").PasteSpecial Paste:=xlPasteValues

If Sheet1.Range("c7") > 0 Then
ThisWorkbook.Worksheets("Sheet1").Range("c7:g7").Copy
Workbooks("Book2.xls").Worksheets("Sheet1").Range("c7:g7").PasteSpecial Paste:=xlPasteValues

If Sheet1.Range("c6") > 0 Then
ThisWorkbook.Worksheets("Sheet1").Range("c8:g8").Copy
Workbooks("Book2.xls").Worksheets("Sheet1").Range("c6:g6").PasteSpecial Paste:=xlPasteValues

Windows("Book3.xls").Activate
ActiveWindow.Close True
Windows("Book2.xls").Activate
End If
End If
End If
End If
End If
End If

mancubus
05-31-2013, 12:18 AM
welcome to the Forum.

try this.


Dim wb As Workbook
Set wb = Workbooks.Open("C:\Users\xxx\Documents\excel\Book2.xls")

With ThisWorkbook.Worksheets("Sheet1")
For i = 3 To 8
If .Range("C" & i) > 0 Then .Range("C" & i & ":G" & i).Copy _
wb.Worksheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Offset(1)
Next
End With

i_malc
06-03-2013, 02:02 PM
Thanks very much. Just a small hitch, I need it to paste into the second spreadsheet at row 8. as rows above are merged and it comes up with an error.

mancubus
06-03-2013, 02:58 PM
you are welcome...


Sub CopyRangeIfConditionMet()

Dim wb As Workbook
Dim i As Long, j As Long

Set wb = Workbooks.Open("C:\Users\xxx\Documents\excel\Book2.xls")

j = 8 'start copy at row 8
With ThisWorkbook.Worksheets("Sheet1")
For i = 3 To 8 'change these numbers to suit your data
If .Range("C" & i) > 0 Then
.Range("C" & i & ":G" & i).Copy _
wb.Worksheets("Sheet1").Range("C" & j)
j = j + 1 'increment the row number to copy if the condition is met
End If
Next
End With

End Sub