Locate and Move Specific Cells

[coperniq]

Hi ;

I couldn't find a way to copy specific cells in an excel sheet, move (copy) them to another sheet and leave the originals. (So ı don't want to cut)

I have found Dave's macro which is really great. But on the other hand, the problem is, it clears content that is moved. (FoundCell.ClearContents) But I want to change it to (FoundCell.Copy) without an infinite loop as you should keep track of the address of the first found cell to stop macro searching the defined cell again and again.

So Could anyone please advise me how to? I have really tried hard but always get another error message

Thanx for your interest.

cop.

Dave Peterson's Macro Code:

Option Explicit
Sub testme()

Dim myWords As Variant
Dim curWks As Worksheet
Dim newWks As Worksheet
Dim FoundCell As Range
Dim iCtr As Long
Dim oRow As Long

myWords = Array("asdf8", "asdf24", "asdf33")

Set curWks = Worksheets("sheet1")
Set newWks = Worksheets.Add

oRow = 0
With curWks
For iCtr = LBound(myWords) To UBound(myWords)
Set FoundCell = Nothing
Do
With .UsedRange
Set FoundCell = .Cells.Find(what:=myWords(iCtr), _
after:=.Cells(.Cells.Count), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlNext, MatchCase:=False)
If FoundCell Is Nothing Then
Exit Do
Else
oRow = oRow + 1
With newWks.Cells(oRow, "A")
.Value = myWords(iCtr)
.Offset(0, 1).Value = FoundCell.Address
End With
FoundCell.ClearContents
End If
End With
Loop
Next iCtr
End With

End Sub

[Jim Thomlinson]

Try something like this. You just need to alter the set statements in the
CopyCells sub...

Sub Test()
Call CopyCells("This")
Call CopyCells("That")
End Sub

Sub CopyCells(ByVal strWordToFind As String)
Dim rngFirst As Range
Dim rngCurrent As Range
Dim rngFoundCells As Range
Dim rngToSearch As Range
Dim wksToSearch As Worksheet
Dim wksToPaste As Worksheet
Dim rngToPaste As Range

Set wksToSearch = Sheets("Sheet1")
Set wksToPaste = Sheets("Sheet2")
Set rngToSearch = wksToSearch.Cells
Set rngToPaste = wksToPaste.Range("A65536").End(xlUp).Offset(1, 0)
Set rngCurrent = rngToSearch.Find(strWordToFind)
If rngCurrent Is Nothing Then
MsgBox strWordToFind & " was not found"
Else
Set rngFirst = rngCurrent
Set rngFoundCells = rngCurrent.Offset(0, 1)
Do
Set rngFoundCells = Union(rngCurrent.Offset(0, 1), rngFoundCells)
Set rngCurrent = rngToSearch.FindNext(rngCurrent)
Loop Until rngFirst.Address = rngCurrent.Address
rngFoundCells.Copy rngToPaste
End If
End Sub
--
HTH...

Jim Thomlinson


"coperniq" wrote:

>
> Hi ;
>
> I couldn't find a way to copy specific cells in an excel sheet, move
> (copy) them to another sheet and leave the originals. (So ı don't
> want to cut)
>
> I have found Dave's macro which is really great. But on the other hand,
> the problem is, it clears content that is moved.
> (FoundCell.ClearContents) But I want to change it to (FoundCell.Copy)
> without an infinite loop as you should
> _keep_track_of_the_address_of_the_first_found_cell_to_stop_macro_searching_the_defined_cell_again_and_again._
>
> So Could anyone please advise me how to? I have really tried hard but
> always get another error message
>
> Thanx for your interest.
>
> cop.
>
> Dave Peterson's Macro Code:
>
> Option Explicit
> Sub testme()
>
> Dim myWords As Variant
> Dim curWks As Worksheet
> Dim newWks As Worksheet
> Dim FoundCell As Range
> Dim iCtr As Long
> Dim oRow As Long
>
> myWords = Array("asdf8", "asdf24", "asdf33")
>
> Set curWks = Worksheets("sheet1")
> Set newWks = Worksheets.Add
>
> oRow = 0
> With curWks
> For iCtr = LBound(myWords) To UBound(myWords)
> Set FoundCell = Nothing
> Do
> With .UsedRange
> Set FoundCell = .Cells.Find(what:=myWords(iCtr), _
> after:=.Cells(.Cells.Count), LookIn:=xlValues, _
> lookat:=xlWhole, searchorder:=xlByRows, _
> searchdirection:=xlNext, MatchCase:=False)
> If FoundCell Is Nothing Then
> Exit Do
> Else
> oRow = oRow + 1
> With newWks.Cells(oRow, "A")
> .Value = myWords(iCtr)
> .Offset(0, 1).Value = FoundCell.Address
> End With
> _FoundCell.ClearContents_
> End If
> End With
> Loop
> Next iCtr
> End With
>
> End Sub
>
>
> --
> coperniq
> ------------------------------------------------------------------------
> coperniq's Profile: http://www.excelforum.com/member.php...o&userid=24901
> View this thread: http://www.excelforum.com/showthread...hreadid=384374
>
>

[coperniq]

Thanks Jim,

Your macro works great. I owe you

Now I have modified and combined Jim's and Dave's codes together. (Just for fun - kinda way to explore new things) The problem is, it pastes the results over the first found cells.

For example: A table like

AAA
AAA
AAA
BBB
BBB
BBB
BBB
CCC
CCC

Condition is cells equals to "AAA" and "CCC" First it copies "AAA" cells to a column specified, then takes "CCC" and paste over "AAA"s But I don't see any reason for this.

Result Should be:

AAA
AAA
AAA
CCC
CCC

Result is:

CCC
CCC
AAA


The code is below. Can anyone show where the problem(reason) is? (I don't need a new code. As I said this is just for learning the possible relations. So please show which part of the code causes this result.)

Thanks everybody....

Cop.

Modified (Combined) Code:

Sub Copyer()

Dim myWords As Variant
Dim curWks As Worksheet
Dim newWks As Worksheet
Dim rngFirst As Range
Dim FoundCell As Range
Dim rngToSearch As Range
Dim rngFoundCells As Range
Dim iCtr As Long
Dim oRow As Long
Dim rngToPaste As Range


myWords = Array("AAA", "CCC")

Set curWks = Worksheets("sheet1")
Set newWks = Worksheets("sheet10")
Set rngToSearch = curWks.Cells
Set rngToPaste = newWks.Range("A65536").End(xlUp).Offset(1, 0)

oRow = 0

With curWks
Set FoundCell = Nothing
For iCtr = LBound(myWords) To UBound(myWords)
With .UsedRange
Set FoundCell = .Cells.Find(what:=myWords(iCtr), _
after:=.Cells(.Cells.Count), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlNext, MatchCase:=False)

If FoundCell Is Nothing Then
MsgBox "No words found."

Else
Set rngFirst = FoundCell
Set rngFoundCells = FoundCell.Offset(0, 0)
Do
Set rngFoundCells = Union(FoundCell.Offset(0, 0), rngFoundCells)
Set FoundCell = rngToSearch.FindNext(FoundCell)
Loop Until rngFirst.Address = FoundCell.Address
rngFoundCells.Copy rngToPaste
End If
End With
Next iCtr
End With
End Sub