Find and transfer
 

Hi, I try again.
I use find, findnext and search in a difrent workbook and when i got the
addresse I need to get non-contiguos cells values and past/transfer to
the active worksheet.
I am looking at collumns A, some time "string" and some time "values"
Look in: Workbook( "Per").worksheets("A").columns."A:A") This workbook is
open, but not active.
columns is like this.
A B C D E F
G
IdNr Ordre Date Text Text Text
Number
41301 610253#1 25.08.04 ...... ...... ...... 2
41301 610253#1 29.08.04 ...... ...... ...... 2
A2501 272834 12.10.04 ...... ...... ...... 18
If there is more then one, they are sortet by Date
Sub b()
Range("b2").Select
With Workbook( "Per"). Worksheets("A").Columns("A:A")
Dim c As Variant
Dim firstAddress As Variant

Set c = .Find(41301, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Dim rngA As Variant
Dim rngB As Variant
Dim rngC As Variant
Dim rngG As Variant
rngA = c.address
rngB = "B" & mid(c.address,4)
rngC = "C" & mid(c.address,4)
rngG = "G" & mid(c.address,4)

activecell = Workbook( "Per"). Worksheets("A").range(rngA).value
activecell.offset(0,1) = Workbook( "Per").workbooks("A").rang(rngB).value
activecell.offset(0,2) = Workbook( "Per").workbooks("A").rang(rngC).value
activecell.offset(0,3) = Workbook( "Per").workbooks("A").rang(rngG).value


ActiveCell.Offset(1, 0).Select


Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address < firstAddress
End If
End With
End Sub

I hope this is enough information.

Regard evgny

Find and transfer
 

Sub GetData()
Workbooks("Per.xls").Worksheets("A").Activate
If ActiveCell.Row = 1 Then
MsgBox "Activecell Can't be in Row 1"
Exit Sub
End If
With Workbooks("Per.xls").Worksheets("A")
If Not Intersect(.Range("a1").CurrentRegion, ActiveCell) _
Is Nothing Then
MsgBox "ActiveCell is in the source data - no place" & _
vbNewLine & " to put the results"
Exit Sub
End If
.Range("IV1").Value = .Range("A1").Value
.Range("IV2").Value = 41301
ActiveCell.Offset(-1, 0).Resize(1, 3).Value = _
.Range("A1:C1").Value
ActiveCell.Offset(-1, 3).Value = .Range("G1").Value
.Range("A1").CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Range("IV1:IV2"), _
CopyToRange:=ActiveCell.Offset(-1, 0).Resize(1, 4), _
Unique:=False
.Columns(256).Delete
End With

End Sub


--
Regards,
Tom Ogilvy

"evgny" wrote in message
...
Hi, I try again.
I use find, findnext and search in a difrent workbook and when i got the
addresse I need to get non-contiguos cells values and past/transfer to
the active worksheet.
I am looking at collumns A, some time "string" and some time "values"
Look in: Workbook( "Per").worksheets("A").columns."A:A") This workbook is
open, but not active.
columns is like this.
A B C D E F
G
IdNr Ordre Date Text Text Text
Number
41301 610253#1 25.08.04 ...... ...... ...... 2
41301 610253#1 29.08.04 ...... ...... ...... 2
A2501 272834 12.10.04 ...... ...... ......
18
If there is more then one, they are sortet by Date
Sub b()
Range("b2").Select
With Workbook( "Per"). Worksheets("A").Columns("A:A")
Dim c As Variant
Dim firstAddress As Variant

Set c = .Find(41301, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Dim rngA As Variant
Dim rngB As Variant
Dim rngC As Variant
Dim rngG As Variant
rngA = c.address
rngB = "B" & mid(c.address,4)
rngC = "C" & mid(c.address,4)
rngG = "G" & mid(c.address,4)

activecell = Workbook( "Per"). Worksheets("A").range(rngA).value
activecell.offset(0,1) = Workbook(
"Per").workbooks("A").rang(rngB).value
activecell.offset(0,2) = Workbook(
"Per").workbooks("A").rang(rngC).value
activecell.offset(0,3) = Workbook(
"Per").workbooks("A").rang(rngG).value


ActiveCell.Offset(1, 0).Select


Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address < firstAddress
End If
End With
End Sub

I hope this is enough information.

Regard evgny