Minulla on A-sarakkeessa tietoa ja pitäisi saada etsittyä tietty aloitusmerkki esim ~290 ja poimittua sitä seuraavat merkit lopetetusmerkkiin asti (esim ~291) toiseen taulukkoon. Jos tieto olisi samalla rivillä, niin osaisin hakea ne, mutta näin en osaa. Eli alla olevasta esimerkistä pitäisi saada poimittua 430, 429, 439 ja 450 toiseen taulukkoon:
A
1 610
2 ~290
3 430
4 429
5 439
6 450 ~291
7 500
8 550
A
1 610
2 ~290
3 430
4 429
5 439
6 450 ~291
7 500
8 550
Vastaukset 3
Vanhimmat
muotoile sopivaksi ...
esim. nyt
hakee Taul1 A -sarakkeesta solunjen E1 ja E2 väliset luvut TAul2 A-sarakkeeseen...
aloitusehto solussa E1
lopetusehto solussa E2
Sub HakuEhdoilla()
On Error Resume Next
Dim Löydetty As Range
Dim Löydetty2 As Range
Dim solu As Range
Dim vika As Long
Set Löydetty = Etsi(Chr(126) & Range("E1"))
Set Löydetty2 = Etsi(Chr(126) & Range("E2"))
Range(Löydetty.Offset(1, 0).Address & ":" & Löydetty2.Address).Copy Worksheets("Taul2").Range("A65536").End(xlUp).Offset(1, 0)
vika = Worksheets("Taul2").Range("A65536").End(xlUp).Row
Worksheets("Taul2").Range("A" & vika) = Left(Worksheets("Taul2").Range("A" & vika), InStr(1, Worksheets("Taul2").Range("A" & vika), "~", 1) - 1)
End Sub
Function Etsi(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Taul1").Activate
With Range("A:A")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set Etsi = solu
End If
End With
End Function
Keep EXCELing
@Kunde
Hei, tämä oli mielenkiintoinen ja toimiva ratkaisu!
Entä jos A-sarakkeella on useampia saman alku- ja lopetusmerkin omaavia kohteita, joiden välit halutaan poimia. Oletuksena näiden määrää ei tiedetä.
Ruokahalu kasvaa syödessä näköjään...
nyt ei väliä montako samaa aluetta löytyy...
Function Etsi(Hakuehto As Variant) As Range
'etsii Sheet1 sarakkeesta A ja siirtää Sheet2 sarakkeeseen O
'oletuksena, että haettavat tiedot vain sarakkeessa A
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Taul1").Activate
With Range("A:A")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set Etsi = solu
EkaOsoite = solu.Address
Do
Set Etsi = Union(Etsi, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address EkaOsoite
End If
End With
End Function
Sub HakuEhdoilla()
On Error Resume Next
Dim Löydetty As Range
Dim Löydetty2 As Range
Dim solu As Range
Dim vika As Long
Set Löydetty = Etsi(Chr(126) & Range("E1"))
Set Löydetty2 = Etsi(Chr(126) & Range("E2"))
If Löydetty.Areas.Count = Löydetty2.Areas.Count Then
For i = 1 To Löydetty.Areas.Count
Range(Löydetty.Areas(i).Cells(1, 1).Offset(1, 0).Address & ":" & Löydetty2.Areas(i).Cells(1, 1).Address).Copy Worksheets("Taul2").Range("A65536").End(xlUp).Offset(1, 0)
vika = Worksheets("Taul2").Range("A65536").End(xlUp).Row
Worksheets("Taul2").Range("A" & vika) = Left(Worksheets("Taul2").Range("A" & vika), InStr(1, Worksheets("Taul2").Range("A" & vika), "~", 1) - 1)
Next
Else
MsgBox "Ristiriita alueiden kanssa"
End If
End Sub
Keep EXCELing
@Kunde