I've waiting til the last minute to do some HW and can't figure this out in time before it's due....

Does anyone here know any Visual Basic and can help me write some basic macro code to search certain values in Excel and then copy them to a new spreadsheet?


here's an example:

I attached a sample problem that we were working on last night. There are a total of 6 problems on each spreadsheet and we need to extract 2 rows of data in each sample problem. Most of the data is in EXCEL spreadsheet and we are writing the code in Microsoft VB.

The actual problem:
BACKWARD DIGIT SPAN EXERCISE
Fri Sep 17 09:07:04 2010 : Time and date of exercise
: Subject identification
1 : Session number
600000 : Test time (milliseconds)
1000 : Stimulus time (milliseconds)
1000 : Inter-stimulus time (milliseconds)
pair # String Answer Response Result
1 642 246 642 Incorrect
2 871 178 178 Correct
3 4651 1564 165 Incorrect
4 3864 4683 4863 Incorrect
4 : Total number of digit spans
1 : Total number of spans correct
3 : Total number of spans incorrect
0 : Total number of spans unanswered
3 : Maximum span correct




For sample problem one, we need to extract the fields:

A13 (4 : Total number of digit spans)
A17 (3 : Maximum span correct)
Then do a simple math equation to divide 3/4 = 75%


The one unusual factor is that in each problem the data location is not always in a pre-determined row (such as A13, A17) but varies with each problem (see the master sheet . Is there a way we can run the search for specific wording (such as "total number of digit spans)?

So far the code we have been trying to use is not working:


--------------------------------------------
Sub Search()

Dim rngSearch As Range
Dim rngFirst As Range

With ThisWorkbook.Worksheets("Sheet1")
With .Columns(1) 'Can put .Range("A1:A30")
Set rngSearch = .Find(What:="Maximum span correct", LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not rngSearch Is Nothing Then
Set rngFirst = rngSearch
Do
rngSearch.EntireRow.Copy Destination:= _
ThisWorkbook.Worksheets("Sheet2").Cells(rngSearch. Row, rngSearch.Column)
Set rngSearch = .FindNext(After:=rngSearch)
Loop While Not rngSearch Is Nothing And rngSearch.Address <> rngFirst.Address
End If
End With
End With

End Sub

 

What do you think it's supposed to be doing that it isn't doing?

I tried running it and it appears to find "Maximum span correct" in column 1 of Sheet1 and copy each row in which it appears to the corresponding row in Sheet2.

It's hard to suggest how to make it right if we don't know why you think it's wrong.

 

thanks for looking at this...

We want the output to extract two lines of data (ones I bolded in the example)

When I run the program, I get an error in line 9? you don't get this?


rick

 

No errors at all.

I added a second loop to scan for "Total number of digit spans", and that worked fine as well (not that I thought it wouldn't).

As you haven't numbered the lines I'm not sure which one is line 9. What sort of error do you get?

If I were writing the code I probably wouldn't copy row X in Sheet1 to row X in Sheet2: I'd have a counter and copy the first instance to row 1, the second to row 2, and so on, but that's just me. (I'd rather have Sheet2 always organized the same way: why continue to make my life difficult?)

I'm in Paris right now and it's quite late, so I won't be able to look at it much longer today, but I'll pop in tomorrow morning to see what's happening.

 

How was Paris? thanks for the suggestions and help....

Sorry for delayed reply, we tried to pull the data based on highlighted strings:


Sub ExtractData()
Dim u As Long
Dim i As Long
Dim j As Long
Dim Rng As Range
Dim m As Long
Dim k As Long
Dim a As Long
Dim b As Long

u = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
Set Rng = Range("B1:B" & u) 'ActiveSheet.UsedRange.SpecialCells(xlCellTypeCons tants)
Sheets("Sheet1").Cells.Clear
k = 1
For i = 1 To u
a = 0
b = 0
If Cells(i, 2).Font.ColorIndex <> -4105 Then
a = i
For j = i + 1 To u
If Cells(j, 2).Font.ColorIndex <> -4105 Then
b = j
Exit For
End If
Next j
If b = 0 Then
b = u
End If
Range("A" & i & ":G" & i).Copy Sheets("Sheet1").Cells(k, 1)
k = k + 1
For m = a + 1 To b
If Cells(m, 2).Interior.ColorIndex <> -4105 Then
Range("A" & m & ":G" & m).Copy Sheets("Sheet1").Cells(k, 1)
k = k + 1
End If
Next m
i = b - 1

End If
Next i


Sheets("Sheet1").Range("AA:AB").ClearContents
MsgBox "Done! " & Chr(10) & k - 1 & " rows have been extracted and copied to Sheet1"
End Sub

 

Paris was cold, snowy, filled with Christmas lights: pretty nice.

It would have been nicer if my wife had been there with me.

I met a couple of magicians for dinner Saturday night (the 11th): one from Paris, one from Newcastle. That was fun.

 

[QUOTE=magician,Dec 30 2010, 04:07 PM]Paris was cold, snowy, filled with Christmas lights: pretty nice.

It would have been nicer if my wife had been there with me.

I met a couple of magicians for dinner Saturday night (the 11th): one from Paris, one from Newcastle.

 

Fixed.

 

Yeah yeah... just be glad only 5 people in total have viewed this thread. You've got a reputation to uphold!

 

ohh