Finding Number Within Range Then Copying Data Below Number to Cells

A

acctemp

Hi,

I have a report which I was able to parse data out of however the
format changed (rendering the programming useless) and I'm looking for
a better solution.

What I need to do is find a 3 digit number (not within another number,
very important) from within a range and then copy/paste information
from the cell below it and the 3 cells to the right of that one to a
range in another part of the spreadsheet. Based on the data below this
is what I would be looking for...

Find the number "101" (see exhibit "A") and then copy 74,980, 0,
22,100.00 and 52,880 to a range in another part of the same spreadsheet
(see exhibit "B").

The same process would continue for number 102, 103, 104, etc.


Exhibit A

101 Mark K Brar
74,980.00 0 22,100.00 52,880.00

102 Mark K Brar
20,580.00 18,000.00 2,070.00 36,510.00

103 Mark K Brar
3,260.63 0 0 3,260.63

104 Mark K Brar
7,759.24 4,064.00 2,105.40 9,717.84

105 Lucy Davenport 10/12/2006
9,839.04 0 0 9,839.04

106 Rebecca Smith 10/12/2006
6,855.24 5,447.00 3,401.57 8,900.67

107 Mark K Brar
3,213.70 0 3,213.70

108 Ralph Jones 8/24/2005
0 0 0 0

Exhibit B:

101 $74,980.00 $0.00 $22,100.00 $52,880.00
102 $20,580.00 $18,000.00 $2,070.00 $36,510.00
103 $3,260.63 $0.00 $0.00 $3,260.63
104 $7,759.24 $4,064.00 $2,105.40 $9,717.84
105 $9,839.04 $0.00 $0.00 $9,839.04
106 $6,855.24 $5,447.00 $3,401.57 $8,900.67
107 $3,213.70 $0.00 $0.00 $3,213.70
108 $0.00 $0.00 $0.00 $0.00
 
S

Sandy

Hey there, try this code out just paste it into a new module(in VBE) in
the workbook.
Make sure to read the comments in the code to change the ranges and the
names of the worksheets:

Sub CopyPaste()
Dim mCell, MyRange, MyCopy As Range
Dim Ws1, Ws2 As Worksheet

'Make sure you set your worksheets
'Ws1 is where your info is
'Ws2 is where you wnt the info to go
'MyRange is obviously your data range in
'Ws1
Set Ws1 = Worksheets("Sheet1")
Set Ws2 = Worksheets("Sheet2")
Set MyRange = Ws1.Range("A1:A16")

For Each mCell In MyRange
If IsNumeric(mCell) And Not _
IsNumeric(mCell.Offset(0, 1).Value) Then
Range(mCell.Offset(1, 0), mCell.Offset(1, 3)).Copy
With Ws2
.Activate
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 1).Select
End With
Selection.Offset(0, -1).Value = mCell.Value
Selection.PasteSpecial xlPasteAll
End If
Next
End Sub


Sandy
 
A

acctemp

Sandy,

Thanks for the quick and helpful reply. I'm not sure if this will
work, perhaps I didn't explain the problem well enough...

The problem with this solution is that it assumes that the range is
always the same. Unfortunately the report changes once in a while and
the numbers move. I wanted to search one large range that easily
accomodate all the data and search by number. If I don't do it this
way the system fails as it cannot tell when 201 has moved into the
position of 107 and puts the wrong data in it.

Below is the entire range where the data would be output to. What I
need is something that will search for "101" (and all the subsequent
numbers) in the whole report and then move the four numbers below it
into the appropriate fields below:




101 $0.00 $0.00 $0.00 $0.00 $- $-
102 $0.00 $0.00 $0.00 $0.00 $- $-
103 $0.00 $0.00 $0.00 $0.00 $- $-
104 $0.00 $0.00 $0.00 $0.00 $- $-
105 $0.00 $0.00 $0.00 $0.00 $- $-
106 $0.00 $0.00 $0.00 $0.00 $- $-
107 $0.00 $0.00 $0.00 $0.00 $- $-
108 $0.00 $0.00 $0.00 $0.00 $- $-

201 $0.00 $0.00 $0.00 $0.00 $- $-
202 $0.00 $0.00 $0.00 $0.00 $- $-
203 $0.00 $0.00 $0.00 $0.00 $- $-
204 $0.00 $0.00 $0.00 $0.00 $- $-
205 $0.00 $0.00 $0.00 $0.00 $- $-
206 $0.00 $0.00 $0.00 $0.00 $- $-

301 $0.00 $0.00 $0.00 $0.00 $- $-
302 $0.00 $0.00 $0.00 $0.00 $- $-
303 $0.00 $0.00 $0.00 $0.00 $- $-
304 $0.00 $0.00 $0.00 $0.00 $- $-
305 $0.00 $0.00 $0.00 $0.00 $- $-
306 $0.00 $0.00 $0.00 $0.00 $- $-
307 $0.00 $0.00 $0.00 $0.00 $- $-

401 $0.00 $0.00 $0.00 $0.00 $- $-
402 $0.00 $0.00 $0.00 $0.00 $- $-
403 $0.00 $0.00 $0.00 $0.00 $- $-
404 $0.00 $0.00 $0.00 $0.00 $- $-
405 $0.00 $0.00 $0.00 $0.00 $- $-
406 $0.00 $0.00 $0.00 $0.00 $- $-

501 $0.00 $0.00 $0.00 $0.00 $- $-
502 $0.00 $0.00 $0.00 $0.00 $- $-
503 $0.00 $0.00 $0.00 $0.00 $- $-
504 $0.00 $0.00 $0.00 $0.00 $- $-
505 $0.00 $0.00 $0.00 $0.00 $- $-
506 $0.00 $0.00 $0.00 $0.00 $- $-

601 $0.00 $0.00 $0.00 $0.00 $- $-
602 $0.00 $0.00 $0.00 $0.00 $- $-
603 $0.00 $0.00 $0.00 $0.00 $- $-
604 $0.00 $0.00 $0.00 $0.00 $- $-
605 $0.00 $0.00 $0.00 $0.00 $- $-

701 $0.00 $0.00 $0.00 $0.00 $- $-
702 $0.00 $0.00 $0.00 $0.00 $- $-
703 $0.00 $0.00 $0.00 $0.00 $- $-
704 $0.00 $0.00 $0.00 $0.00 $- $-
705 $0.00 $0.00 $0.00 $0.00 $- $-
706 $0.00 $0.00 $0.00 $0.00 $- $-
 
S

Sandy

Hey there try this code modification and see if it works

Sub UpDateCells()
Dim mCell, MyRange, MyCopy As Range
Dim Ws1, Ws2 As Worksheet
Dim mFound As Range
Set Ws1 = Worksheets("Sheet1")
Set Ws2 = Worksheets("Sheet2")
'Check the first column for the number
Set MyRange = Ws1.Range("A1:A16") ' or whatever
'the range is"

For Each mCell In MyRange
If IsNumeric(mCell) And Not _
IsNumeric(mCell.Offset(0, 1).Value) Then
Range(mCell.Offset(1, 0), mCell.Offset(1, 3)).Copy
With Ws2.Columns("A")
Set mFound = .Find _
(mCell, , LookIn:=xlValues)
End With
Ws2.Activate
mFound.Offset(0, 1).Select
Selection.PasteSpecial xlPasteAll
End If
Next
Application.CutCopyMode = False
End Sub

Let me know how this works out.

Sandy
 
A

acctemp

Thanks, I'll give it a try on Monday. I'm puzzled as to how the code
figures out where to put the results though. The data range is
B130-G400 and the output ranges are B5:E12, B22:E27, B37:E43, B53:E58,
B68:E73, B83:E87, and B100:E105. Both are on the same worksheet.
 
A

acctemp

Hi,

Tried this code but could not get it to work. The data needs to be on
the same spreadsheet and must go to designated locations. Also I got
an error "Method 'Range of Object' worksheet failed" at this
breakpoint:

Range(mCell.Offset(1, 0), mCell.Offset(1, 3)).Copy

Here is the code I have so far:

Dim mCell, MyRange, MyCopy As Range
Dim Ws1, Ws2 As Worksheet
Dim mFound As Range
Set Ws1 = Worksheets("10-16")
Set Ws2 = Worksheets("Sheet2")
'Check the first column for the number
Set MyRange = Ws1.Range("B129:E400") ' or whatever
'the range is"


For Each mCell In MyRange
If IsNumeric(mCell) And Not _
IsNumeric(mCell.Offset(0, 1).Value) Then
Range(mCell.Offset(1, 0), mCell.Offset(1, 3)).Copy
With Ws2.Columns("A")
Set mFound = .Find _
(mCell, , LookIn:=xlValues)
End With
Ws2.Activate
mFound.Offset(0, 1).Select
Selection.PasteSpecial xlPasteAll
End If
Next
Application.CutCopyMode = False
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

VBA Programming help 2
Need help with VBA code 0
Sort data 2
Weird Behaviour Function not invoked 3
Cross-Referencing Data 0
Copy in order 3
Source and Destination 1
Using AdvancedFilter on range of data 0

Top