Moving & copying between two workbooks

[Sephir]

Hello!

I am trying to copy some cells from one workbook to another. Here is the peace of code:

For i = 1 to 100
If Cells(i, "A").Value = "Start" Then
Cells(i, "A").Select
Cells(i, "A").Copy_ Destination:=Workbooks(2).Sheets(1).Range("A1").End(xlDown)
End If
Next i

I want to copy entire row of finded cell. Any help with this?

My other questions are:

1. is there some simple way to copy to closed workbook?
2. After founding "Start" value, I want to search for End value and copy whole range between them. How to do that????

Thank you for any help!

[Sephir]

Any help with this?

[lucas]

To be clear on what you're trying to do....you want to search column A from top to bottom and copy all rows that have data in column A to a different sheet?

[Sephir]

To be clear on what you're trying to do....you want to search column A from top to bottom and copy all rows that have data in column A to a different sheet?

i want to seach column A, starting at "Start" to bottom, copy all rows and finish on row, with "End" in column A.

[Charlize]

Not tested. Sub StartEnd()
Dim rng As Range
Dim result, result2
Dim firstaddress As String
Dim vmessage As String
Dim wb As Workbook
Dim current As Workbook
Dim sht As Worksheet
Dim rng2 As Range

Set current = ActiveWorkbook
Set wb = Workbooks.Add
Set sht = wb.Sheets(1)
Set rng2 = sht.Range("A" & sht.Range("A" & Rows.Count).End(xlUp).Row + 1)
current.Activate
Set rng = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
With rng
Set result = .Find("Start", LookIn:=xlValues)
If Not result Is Nothing Then
firstaddress = result.Address
Do
vmessage = vmessage & "- start : " & result.Row & vbCrLf
Set result = .FindNext(result)
Loop While Not result Is Nothing And result.Address <> firstaddress
End If
Set result2 = .Find("End", LookIn:=xlValues)
If Not result2 Is Nothing Then
firstaddress = result2.Address
Do
vmessage = vmessage & "- End : " & result2.Row & vbCrLf
Set result2 = .FindNext(result)
Loop While Not result2 Is Nothing And result2.Address <> firstaddress
End If
End With
Range(Cells(result.Row, 1), Cells(result2.Row, 1)).Copy rng2
End Subvmessage ins't really necessary. Dimming and building of vmessage can be deleted.

[CicoMico]

hey. thanx for the code, but it is not working... it starts and then just sits there forever... any help? Sephir did you managed to get it working?

[Sephir]

hey. thanx for the code, but it is not working... it starts and then just sits there forever... any help? Sephir did you managed to get it working?

No, I did not. Any help, somebody? Please...

[Charlize]

Works fine for me. In column A I have in A3 the word start and in A10 the word end. Now, everything in between those two words is copied to a new created workbook. Instead of creating one, you could easily change the coding to open an existing workbook.

[Sephir]

Works fine for me. In column A I have in A3 the word start and in A10 the word end. Now, everything in between those two words is copied to a new created workbook. Instead of creating one, you could easily change the coding to open an existing workbook.

Hmmm... That is strange! I've created new wb with these datas: A1 - Start, A10 - End; A20 - Start, A25 - End; inserted Your code into new module and run. Excel stopped responding and freezes... Any suggestions?

[Charlize]

The previous codes weren't for multiple copies of data between start and end. Try this suggestion instead.Sub StartEnd()
Dim rng As Range
Dim result, result2
Dim wb As Workbook
Dim current As Workbook
Dim sht As Worksheet
Dim rng2 As Range

Set current = ActiveWorkbook
Set wb = Workbooks.Add
Set sht = wb.Sheets(1)
current.Activate
Set rng = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
Do
Set rng2 = sht.Range("A" & sht.Range("A" & Rows.Count).End(xlUp).Row + 1)
With rng
Set result = .Find("Start", LookIn:=xlValues)
If Not result Is Nothing Then
Set result2 = .Find("End", LookIn:=xlValues)
Else
Exit Do
End If
End With
Range(Cells(result.Row, 1), Cells(result2.Row, 1)).Copy rng2
Set rng = Range(Cells(result2.Row, result2.Column), _
Range("A" & Range("A" & Rows.Count).End(xlUp).Row))
Loop While result2.Row < Range("A" & Rows.Count).End(xlUp).Row
End Sub

[Sephir]

hey! thanx for helping and for your patience. but unfortunately it is still not working for me. I am posting sample wb with source and results... please help!

[Charlize]

This will do it. It's because you putted a Start in A1. First time looking when using Find will skip A1.Option Explicit
Option Compare Text
Sub StartEnd()
'starting range
Dim rng As Range
'store lookup results
Dim result, result2
'workbook that we use
Dim current As Workbook
'sheet to copy to
Dim sht As Worksheet
'range to copy to
Dim rng2 As Range

Set current = ActiveWorkbook
Set sht = current.Worksheets("Result")
current.Activate
Set rng = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
'if destination A1 <> empty
If sht.Range("A1") <> "" Then
Set rng2 = sht.Range("A" & sht.Range("A" & Rows.Count).End(xlUp).Row + 1)
Else
Set rng2 = sht.Range("A1")
End If
'Because find function will skip A1 when starting
'we have to check it by using an if construction
If Range("A1").Value = "Start" Then
Set result = Range("A1")
Set result2 = rng.Find("End", LookIn:=xlValues)
Range(Cells(result.Row, 1), Cells(result2.Row, 1)).Resize(, 3).Copy rng2
Set rng = Range(Cells(result2.Row, result2.Column), _
Range("A" & Range("A" & Rows.Count).End(xlUp).Row))
End If
Do
'if destination A1 <> empty
If sht.Range("A1") <> "" Then
Set rng2 = sht.Range("A" & sht.Range("A" & Rows.Count).End(xlUp).Row + 1)
Else
Set rng2 = sht.Range("A1")
End If
With rng
Set result = .Find("Start", LookIn:=xlValues)
'if start is found, we look for End
'else exit the loop to avoid errors when searching for End
If Not result Is Nothing Then
Set result2 = .Find("End", LookIn:=xlValues)
Else
Exit Do
End If
End With
'resize the range to be copied from 1 to 3 columns
Range(Cells(result.Row, 1), Cells(result2.Row, 1)).Resize(, 3).Copy rng2
Set rng = Range(Cells(result2.Row, result2.Column), _
Range("A" & Range("A" & Rows.Count).End(xlUp).Row))
'if rowno of result2 (End) < total number of rows, we check again on
'start value
Loop While result2.Row < Range("A" & Rows.Count).End(xlUp).Row
End Sub

[Sephir]

This will do it. It's because you putted a Start in A1. First time looking when using Find will skip A1.Option Explicit
Option Compare Text
Sub StartEnd()
'starting range
Dim rng As Range
'store lookup results
Dim result, result2
'workbook that we use
Dim current As Workbook
'sheet to copy to
Dim sht As Worksheet
'range to copy to
Dim rng2 As Range

Set current = ActiveWorkbook
Set sht = current.Worksheets("Result")
current.Activate
Set rng = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
'if destination A1 <> empty
If sht.Range("A1") <> "" Then
Set rng2 = sht.Range("A" & sht.Range("A" & Rows.Count).End(xlUp).Row + 1)
Else
Set rng2 = sht.Range("A1")
End If
'Because find function will skip A1 when starting
'we have to check it by using an if construction
If Range("A1").Value = "Start" Then
Set result = Range("A1")
Set result2 = rng.Find("End", LookIn:=xlValues)
Range(Cells(result.Row, 1), Cells(result2.Row, 1)).Resize(, 3).Copy rng2
Set rng = Range(Cells(result2.Row, result2.Column), _
Range("A" & Range("A" & Rows.Count).End(xlUp).Row))
End If
Do
'if destination A1 <> empty
If sht.Range("A1") <> "" Then
Set rng2 = sht.Range("A" & sht.Range("A" & Rows.Count).End(xlUp).Row + 1)
Else
Set rng2 = sht.Range("A1")
End If
With rng
Set result = .Find("Start", LookIn:=xlValues)
'if start is found, we look for End
'else exit the loop to avoid errors when searching for End
If Not result Is Nothing Then
Set result2 = .Find("End", LookIn:=xlValues)
Else
Exit Do
End If
End With
'resize the range to be copied from 1 to 3 columns
Range(Cells(result.Row, 1), Cells(result2.Row, 1)).Resize(, 3).Copy rng2
Set rng = Range(Cells(result2.Row, result2.Column), _
Range("A" & Range("A" & Rows.Count).End(xlUp).Row))
'if rowno of result2 (End) < total number of rows, we check again on
'start value
Loop While result2.Row < Range("A" & Rows.Count).End(xlUp).Row
End Sub


perfect! thanx! just one question... i have added some colums and it gives me: Run-time error: '1004'. The information cannot be pasted becouse the copy area and the paste area are not the same size and shape...
Range(Cells(result.Row, 1), Cells(result2.Row, 1)).Resize(, 3).Copy rng2

i changed 3 to 5, and same error...
Range(Cells(result.Row, 1), Cells(result2.Row, 1)).Resize(, 5).Copy rng2

any help with this? thanx

[Charlize]

Post your workbook exactly formatted as you would use it. Probably something to do with merged cells.

[Sephir]

Post your workbook exactly formatted as you would use it. Probably something to do with merged cells.
unfortunately i can't. it's part of unreleased project... anyway, i've searched for merged cells, and no merged cells in my wb... it has 1323 rows and 5 colums.

[Charlize]

Take a look at this : http://support.microsoft.com/kb/210684

[Sephir]

Take a look at this : http://support.microsoft.com/kb/210684

hmmm... still the same error...