Extract Data Between Cell Ranges

[billmar]

I've come to a halt on a text file project, maybe someone can shed som
light on my next steps.

2 questions using the following example, assume this data is in colum
A and appears many times with different numeric values beyween Data an
Data1.

Data
1
1a
2
3
3a
4
5
6
7
8
9
Data1

1 - I need to create a macro that finds the first appearance of Dat
and counts the number of cells between Data and Data 1. If there ar
less than 8 no action is taken and it moves onto the next appearance o
Data.

2 - If 8 or more cells are present, the macro extracts the value of
pre-identified cells and pastes their value in the 3 adjecent column
next to the cell containing the word Data.

The pre-identified cells, as an example could be, A=1st value afte
Data, B=4th value after data and C=5th value after data. In this cas
the result would be 1 3 3a


Any help or advice will be greatly appreciated.

Bil

 

[Guest]

Range("A1").CurrentRegion.Select
Selection.Find(What:="Data#").Activate
Debug.Print ActiveCell.Row
Selection.Find(What:="Data#", After:=ActiveCell).Activate
Debug.Print ActiveCell.Row

Depending on pattern of Data cells, above will give you their row numbers.
The rest is programming exercise

 

[Myrna Larson]

I'm not entirely clear on whether the cells contain the words "Data1",
"Data2", "Data3", etc, or just "Data". See the comment in the code if it's the
former. Also assume there will not be more than 1000 entries between
occurrences of the word "Data".

Change the constants MaxEntries, A, B, and C as necessary.

Option Explicit

Sub MoveData()
Dim D1 As Long
Dim D2 As Long
Dim D3 As Long
Dim Flag As String
Dim X As Variant

'offsets of values to be copied
Const A As Long = 1
Const B As Long = 4
Const C As Long = 5

'maximum number of data points between occurrences
'of the flag word
Const MaxEntries As Long = 1000
Const MinEntries As Long = 8

Flag = "Data"

'create a stopping point by writing the flag word
'at the bottom of the real data
D3 = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(D3, 1).Value = Flag

'if the flags are Data1, Data2, etc, uncomment the next line <<<<<
'Flag = Flag & "*"

'find the first occurrence
D1 = Application.Match(Flag, Cells(1, 1).Resize(MaxEntries, 1), 0)
If D1 = D3 Then
MsgBox Flag & " not found!"
Cells(D3, 1).ClearContents
Exit Sub
End If

Do
D2 = Application.Match(Flag, Cells(D1 + 1, 1).Resize(MaxEntries, 1), 0)
If D2 > MinEntries Then
X = Array(Cells(D1 + A, 1).Value, _
Cells(D1 + B, 1).Value, _
Cells(D1 + C, 1).Value)
Cells(D1, 2).Resize(1, 3).Value = X
End If

D1 = D1 + D2
If D1 = D3 Then Exit Do
Loop
Cells(D3, 1).ClearContents
End Sub

 

[R.VENKATARAMAN]

I have given a sub below which may be pedestrian but seems to work

THE FIRST ENTRY OF "DATA" IS IN A2 ----I.E. IN THE SECOND ROW

Public Sub test()
Range("a1").Activate
Dim dataa As Range
Dim i As Integer
Dim j As Integer
Cells.Find("data", lookat:=xlWhole, after:=ActiveCell).Activate
i = ActiveCell.Row
Set dataa = ActiveCell
'msgbox ActiveCell
Cells.Find("data1", lookat:=xlWhole, after:=ActiveCell).Activate
'msgbox ActiveCell
j = ActiveCell.Row
If j - i - 1 >= 8 Then
dataa.Offset(1, 1) = dataa.Offset(1, 0)
dataa.Offset(4, 1) = dataa.Offset(4, 0)
dataa.Offset(5, 1) = dataa.Offset(5, 0)
Else
End If


Do
Cells.Find("data", lookat:=xlWhole, after:=ActiveCell).Activate
i = ActiveCell.Row
Set dataa = ActiveCell

'msgbox ActiveCell
Cells.Find("data1", lookat:=xlWhole, after:=ActiveCell).Activate

'msgbox ActiveCell
j = ActiveCell.Row
If j - i - 1 >= 8 Then
dataa.Offset(1, 1) = dataa.Offset(1, 0)
dataa.Offset(4, 1) = dataa.Offset(4, 0)
dataa.Offset(5, 1) = dataa.Offset(5, 0)
Else
End If
Loop While i <> 2

End Sub
modify to suit you

perhaps you miight have received more sophisticated solution by this time.

 

[billmar]

What a great response.....

Thanks PY, Myrna and R.V, you've gotten me going again. I have a lot
here to work with and I can't thank you enough.

Bill