Scan and Copy

[innoin]

Hello! I will start by saying that I don't really know anything about coding or VBA...other than copying the help all of you have given me in the past to a new module and connecting that to a button.


So! I'm hoping someone here will find this ridiculously simple and be able to help me. I have to compile A LOT of data and will need to look through thousands of spreadsheets. I'll be doing between one and 20-ish sheets at a time. I have an excel file with some VBA I attached to a button that lets me combine multiple Excel files into one document (puts all sheets onto their own individual tab and then returns me to a "Results" tab).

I want to do the following:


1. Scan across multiple tabs
2. Starting with the first tab, I want to copy F10 and C12 to cells A1 and B1 of the "Results" tab
3. Then search for the first instance of the word "Circle" or "Sphere" in column A (this might not be just "Circle"...it may be Circle1 or Circle A or Sphere One or any variation of other things around the word "Circle" or "Sphere")
4. When the first instance of this word is found, copy it to cell A2 of the "Results" tab
5. Then continue scanning down and look for the word "Diameter" in the same column
6. When it's found, copy the cell to the right of it (for example, if it's on cell A5 then copy B5) to cell B2 of the "Results" tab
7. Then continue scanning for the next instance of the word word "Circle" or "Sphere"
8. Repeat steps 2 through 7 and continue down until the end of the first imported tab
9. Repeat steps 2 through 8 so there's no gaps in data.


I don't know if this is possible or if I even made any sense. Thanks for any help anyone can give me!

 

[rpaulson]

try this: make sure you "results" sheet is the active sheet when you run it.

Sub do_it()

wr = 1

Dim ws As Worksheet

For Each ws In Worksheets
If ws.Name <> "Results" Then

Cells(wr, "A") = ws.[F10]
Cells(wr, "B") = ws.[C12]
wr = wr + 1

For r = 1 To ws.Cells(Rows.Count, "A").End(xlUp).Row
If InStr(UCase(ws.Cells(r, "A")), "CIRCLE") > 0 Or InStr(UCase(ws.Cells(r, "A")), "SPHERE") > 0 Then
Cells(wr, "A") = ws.Cells(r, "A").Value
wr = wr + 1
End If

If InStr(UCase(ws.Cells(r, "A")), "DIAMETER") > 0 Then
Cells(wr - 1, "B") = ws.Cells(r, "B").Value
End If
Next r

End If

Next ws

End Sub

hth,

Ross

 

[innoin]

I just replicated what I will be doing and it seemed to work perfectly! Thank you! I'll let you know if I run into any problems once I actually start running the real spreadsheets tonight.

 

[innoin]

Hello, I just tested it and it works almost perfectly. Would it be possible to add something that would skip occurrences of the word "Circle" if the cell next to it is empty? I forgot that mixed throughout the data are random areas with the word "circle" in a sentence with nothing in the B column next to it, so it's pulling that data in as well. Thanks again!

 

[innoin]

And hello again! Just wanted to say that I searched around and found something on another board that I added to your code to achieve what I wanted...Kind of roundabout but it works! I think it just searches and deletes the unwanted rows after it's placed on the Results tab if columns B and C are empty. I'll include the code below in case it helps someone who randomly stumbles on this thread. Thanks again, again!

<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">Columns("B:C").Select
Set rngRange = Selection.CurrentRegion
lngNumRows = rngRange.Rows.Count
lngFirstRow = rngRange.Row
lngLastRow = lngFirstRow + lngNumRows - 1
lngCompareColumn = ActiveCell.Column
For lngCurrentRow = lngLastRow To lngFirstRow Step -1
If (Cells(lngCurrentRow, lngCompareColumn).Text = "") Then _
Rows(lngCurrentRow).Delete
Next lngCurrentRow</code>

 

[innoin]

Hmmm, sorry for replying to my own post four times...That line didn't work as well as I'd hoped it would. I want to make some small alterations and it deletes rows I don't want deleted once I make those alterations. So, back to the original problem. If you have a solution for not including the circle names if there's nothing in the cell next them, I'd be in your debt! A debt I can't repay because I don't know anything about VBA.

 

[rpaulson]

try this:

If InStr(UCase(ws.Cells(R, "A")), "CIRCLE") > 0 Or InStr(UCase(ws.Cells(R, "A")), "SPHERE") > 0 And ws.Cells(R, "B") <> "" Then

 

[innoin]

Yep, that worked! Thank you!

One more question regarding this if you're still around: What if I wanted to add more features to it? Instead of just searching for "Diameter", could I also have it search for "Roundness" as well? Also, would it be possible to make it pull two cells instead of one if this word is found? For example, could it report cells D and E next to the word "Roundness" into the results columns B and C?