Searching Cells for String

[Cabble]

Hi i have a table of data, where there is going down a series of parameters, and going across various readings for these parameters, now i am trying to format the data and move it into another workbook, and i was wanting to use a for loop to search for a string i.e. parameter name and from this activate code to move certain bits from that parameter row into another a workbook

Dim MyString As String
Dim c As Object
Dim i As Long
MyString = "Leq"


For Each c In Sheets("Original").Range("A1:A65536").Cells

If c = MyString Then i = ActiveCell.Row

Range("D" & i, "N" & i).Select


Selection.Copy
Windows("NA28 Thirds To Table.xls").Activate
Sheets("NA28 Table Oct Summary").Select
Range("O" & i).Select
ActiveSheet.Paste
Windows("mybook").Activate
Next

End Sub
This is what i have at the minute but it doesn't seem to work, i'm not a complete novice programmer but am when it comes to VBA.

thanks in advance, Dan. :)

[Bob Phillips]

No tested, but try this



Dim MyString As String
Dim c As Range
Dim i As Long
MyString = "Leq"

With Sheets("Original")

For Each c In .Range("A1:A" & .Cells(.Rows.Count, "A").xlUp.Row).Cells

If c = MyString Then i = c.Row

.Range("D" & i, "N" & i).Copy _
Workbooks("NA28 Thirds To Table.xls").Sheets("NA28 Table Oct Summary").Range("O" & i)
End If
Next
End With

End Sub

[Cabble]

No joy so far, am getting a block if error, also due to the nature of the orignal data there are several blank rows where the end of one test's worth of data ends and the next begins so the code to find the last blank row is redundant. its a rather annoying one this routine.

[Ebrow]

Sub test()
Dim MyString As String
Dim c
Dim i As Long
MyString = "Leq"


For Each c In Sheet1.UsedRange.Cells

MsgBox c.Address

If c = MyString Then
i = ActiveCell.Row
Range("D" & i, "N" & i).Select

Selection.Copy

Windows("NA28 Thirds To Table.xls").Activate
Sheets("NA28 Table Oct Summary").Select
Range("O" & i).Select
ActiveSheet.Paste

Windows("mybook").Activate
Next

End Sub

[Bob Phillips]

Sorry, my bad



Dim MyString As String
Dim c As Range
Dim i As Long
MyString = "Leq"

With Sheets("Original")

For Each c In .Range("A1:A" & .Cells(.Rows.Count, "A").xlUp.Row).Cells

If c = MyString Then

i = c.Row

.Range("D" & i, "N" & i).Copy _
Workbooks("NA28 Thirds To Table.xls").Sheets("NA28 Table Oct Summary").Range("O" & i)
End If
Next
End With

End Sub

[Cabble]

Thanks guys between the two codes i modified my original code and got it to work as such

Dim MyString As String
Dim c
Dim i As Long
MyString = "Leq"

For Each c In Sheets("Original").Range("A1:A65536").Cells

If c = MyString Then
i = c.Row
Range("D" & i, "N" & i).Select

Selection.Copy
Workbook("NA28 Thirds To Table.xls").Sheets("NA28 Table Oct Summary").Range ("O" & i)
ActiveSheet.Paste
Windows("mybook").Activate

End If
Next

End Sub

now i've just got to move the rest of the data, but having got this done, i can use it as a template. :bow:

[Ebrow]

You should try and use this code in a function if you are doing it over many sheets/different search strings.


Function myParseFindDate (mySheetName as string, myRange as string, mySearchStr as string)

Dim c
Dim i As Long

For Each c In Sheets(mySheetName).Range(myRange).Cells

If c = mySearchStr Then
i = c.Row
Range("D" & i, "N" & i).Select

Selection.Copy
Workbook("NA28 Thirds To Table.xls").Sheets("NA28 Table Oct Summary").Range ("O" & i)
ActiveSheet.Paste

Windows("mybook").Activate

End If
Next

End Function

'Use this sub to test the code.


Sub test

call myParsheFindDate ("Original","A1:A65536","Leq")

End Sub

[Ebrow]

Sub test

call myParseFindDate ("Original","A1:A65536","Leq")

End Sub

sorry code at end should read like this.

[mdmackillop]

Rather than looping each cell, it's usually more efficient to Find each value and run the code using the found range
Option Explicit

Sub DoCopy()

Dim MyString As String
Dim c As Range
Dim i As Long
Dim ws As Worksheet
Dim FirstAddress As String

Set ws = Workbooks("NA28 Thirds To Table.xls").Sheets("NA28 Table Oct Summary")
MyString = "Leq"

With Sheets("Original").Columns(1)
Set c = .Find(MyString)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
i = c.Row
Range("D" & i, "N" & i).Copy ws.Range("O" & i)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
End Sub