Code copies between key word is in reverse order

  • Thread starter Thread starter Howard
  • Start date Start date
H

Howard

I dug this out of my archives, modified it slightly for a Poster.

Using XX and XXX as "key words" multiple times in column A, it does pretty well. Grabs the ranges from the Start Key word to the End Key word (including the Start and End words), puts them in column B, clears column A and returns the data from column B back to column A.

The end result in column A is accurate, however, it is in reverse order of how it was originally listed in A. Would prefer it to be in same order as original.

Another preference would be to only take the data BETWEEN the start and endwords and when copied to column B, a blank cell would be between each range.

I'm pretty sure I can just go to column B and remove the start and end words with extra code before bringing column B back to A. Was wondering if it makes better sense to just offset from start word one cell down and from end word one cell up and move that range segment to B, perhaps with an offset(1, 0) to produce the blank between each range in column B.

But I can't figure how to exclude the start and end words.

Any suggestions?
Thanks,
Howard

Option Explicit

Sub Copy_Twixt_Keywords()

Dim rngKeyWordStart As Range, rngKeyWordEnd As Range
Dim strKeyWordStart As String, strKeyWordEnd As String, FirstFound As String

'strKeyWordStart = Range("K1").Value
strKeyWordStart = "XX"

'strKeyWordEnd = Range("K2").Value
strKeyWordEnd = "XXX"

Application.ScreenUpdating = False
With Sheets("Sheet1")
Set rngKeyWordStart = .Range("A:A").Find(What:=strKeyWordStart,_
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext,_
MatchCase:=False)

If Not rngKeyWordStart Is Nothing Then

FirstFound = rngKeyWordStart.Address

Set rngKeyWordEnd = .Range("A:A").Find(What:=strKeyWordEnd,_
After:=rngKeyWordStart)

If Not rngKeyWordEnd Is Nothing Then
Do
.Range(rngKeyWordStart, rngKeyWordEnd).Copy
Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).PasteSpecial xlPasteValues

Set rngKeyWordStart = .Range("A:A").Find(What:=strKeyWordStart, _
After:=rngKeyWordEnd)
Set rngKeyWordEnd = .Range("A:A").Find(What:=strKeyWordEnd, _
After:=rngKeyWordStart)

Loop While rngKeyWordStart.Address <> FirstFound And _
rngKeyWordEnd.Row > rngKeyWordStart.Row
Else
MsgBox "Cannot find a match for the 'End' keyword: " & _
vbLf & """" & strKeyWordEnd & """", _
vbExclamation, "No Match Found"
End If

Else
MsgBox "Cannot find a match for the 'Start' keyword: " & _
vbLf & """" & strKeyWordStart & """", _
vbExclamation, "No Match Found"
End If

End With

Application.CutCopyMode = True
Application.ScreenUpdating = True

Range("A:A").ClearContents
Range("B:B").Copy Range("A1")
Range("B:B").ClearContents
End Sub
 
Hi Howard,

Am Mon, 26 Aug 2013 22:21:38 -0700 (PDT) schrieb Howard:
The end result in column A is accurate, however, it is in reverse order of how it was originally listed in A. Would prefer it to be in same order as original.
Click to expand...

in my tests the result is in the same order. Comment out the last three
lines in your code and you see, that the order is correct.
Another preference would be to only take the data BETWEEN the start and end words and when copied to column B, a blank cell would be between each range.
Click to expand...

then try:
..Range(rngKeyWordStart.Offset(1, 0), rngKeyWordEnd.Offset(-1, 0)).Copy
Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp). _
Offset(2, 0).PasteSpecial xlPasteValues

At the end of your code why don't you delete column A? Column B then is
automatically column A.


Regards
Claus B.
 
Hi Claus,
Hmmm, I thought I saw results as you described them to be a couple of times in testing but now here is what I get.

I inserted your code snippet and added a deletion of column A.
Here is what I get, where the right hand column below was what I had in column A, A1 to A25 and the left hand column is the results starting in A3 to A14 after running the code.

XX
nn1
nn7 nn2
nn8 XXX
nn9 nn4
nn10 nn5
XX
nn15 nn7
nn16 nn8
nn17 nn9
nn18 nn10
XXX
nn1 nn12
nn2 nn13
XX
nn15
nn16
nn17
nn18
XXX
nn20
nn21
nn22
nn23
nn24


Regards,
Howard
 
Hi Claus,

Hmmm, I thought I saw results as you described them to be a couple of times in testing but now here is what I get.



I inserted your code snippet and added a deletion of column A.

Here is what I get, where the right hand column below was what I had in column A, A1 to A25 and the left hand column is the results starting in A3 to A14 after running the code.



XX

nn1

nn7 nn2

nn8 XXX

nn9 nn4

nn10 nn5

XX

nn15 nn7

nn16 nn8

nn17 nn9

nn18 nn10

XXX

nn1 nn12

nn2 nn13

XX

nn15

nn16

nn17

nn18

XXX

nn20

nn21

nn22

nn23

nn24





Regards,

Howard
Click to expand...

Drat, that did not post up very well.

Hope you can use your imagination and align that into two columns.

Howard
 
Hi Howard,

Am Tue, 27 Aug 2013 01:24:26 -0700 (PDT) schrieb Howard:
Drat, that did not post up very well.
Click to expand...

never mind.
Try:
Sub Test2()
Dim strStart As String
Dim strEnd As String
Dim RStart As Range
Dim REnd As Range
Dim LRow As Long
Dim i As Long

strStart = "XX"
strEnd = "XXX"
i = 1

LRow = Cells(Rows.Count, 1).End(xlUp).Row
Do
Set RStart = Range(Cells(i, 1), Cells(LRow, 1)).Find _
(strStart, Cells(LRow, 1), xlValues, xlWhole)
If Not RStart Is Nothing Then
Set REnd = Range(Cells(i, 1), Cells(LRow, 1)).Find _
(strEnd, Cells(RStart.Row, 1), xlValues, xlWhole)
Range(RStart.Offset(1, 0), REnd.Offset(-1, 0)).Copy
Range("B" & Rows.Count).End(xlUp).Offset(2, 0) _
.PasteSpecial xlPasteValues
i = REnd.Row
End If
Loop While i < LRow And Not RStart Is Nothing
End Sub


Regards
Claus B.
 
Try:
Sub Test2()

Dim strStart As String

Dim strEnd As String

Dim RStart As Range

Dim REnd As Range

Dim LRow As Long

Dim i As Long



strStart = "XX"

strEnd = "XXX"

i = 1



LRow = Cells(Rows.Count, 1).End(xlUp).Row

Do

Set RStart = Range(Cells(i, 1), Cells(LRow, 1)).Find _

(strStart, Cells(LRow, 1), xlValues, xlWhole)

If Not RStart Is Nothing Then

Set REnd = Range(Cells(i, 1), Cells(LRow, 1)).Find _

(strEnd, Cells(RStart.Row, 1), xlValues, xlWhole)

Range(RStart.Offset(1, 0), REnd.Offset(-1, 0)).Copy

Range("B" & Rows.Count).End(xlUp).Offset(2, 0) _

.PasteSpecial xlPasteValues

i = REnd.Row

End If

Loop While i < LRow And Not RStart Is Nothing

End Sub
Click to expand...
Regards

Claus B.
Click to expand...


Very nice! As always, thanks Claus.

Regards,
Howard
 
Back
Top