Hep!
Löytyisikö apua? Kahdessa taulukossa tietoja samoista asioista, tietoja pitäisi voida koota molemmista. Eli ensimmäisessä sarakkeina nimi, ikä, kunta ja ammatti. Toisessa samoista henkilöistä nimi, ikä, syntymäkunta, tulotaso ja kuukaudet jolloin on ollut lomalla. Tarve olisi lisätä taulukkoon kaksi nuo puuttuvat kaksi saraketta (kunta ja ammatti) oikeiden henkilöiden kohdalle. Järjestys ei ole sama vaan täysin satunnainen ja taulukko on iso, joten automatisointi kiinnostaisi data filtterin sijaan. Onnistuuko jossittelemalla vai onko muita käyttökelposia (paste, vlookup?) funktioita? Eli esim. ensimmäisestä taulukosta ehdoilla Matti, 46, löytyvät tiedot taulukkoon kaksi riveille, joissa myös esiintyy Matti, 46. Kiitokset ja syksyä!!
Löytyisikö apua? Kahdessa taulukossa tietoja samoista asioista, tietoja pitäisi voida koota molemmista. Eli ensimmäisessä sarakkeina nimi, ikä, kunta ja ammatti. Toisessa samoista henkilöistä nimi, ikä, syntymäkunta, tulotaso ja kuukaudet jolloin on ollut lomalla. Tarve olisi lisätä taulukkoon kaksi nuo puuttuvat kaksi saraketta (kunta ja ammatti) oikeiden henkilöiden kohdalle. Järjestys ei ole sama vaan täysin satunnainen ja taulukko on iso, joten automatisointi kiinnostaisi data filtterin sijaan. Onnistuuko jossittelemalla vai onko muita käyttökelposia (paste, vlookup?) funktioita? Eli esim. ensimmäisestä taulukosta ehdoilla Matti, 46, löytyvät tiedot taulukkoon kaksi riveille, joissa myös esiintyy Matti, 46. Kiitokset ja syksyä!!
Vastaukset 6
Vanhimmat
Matriisikaavana INDEKSI(VASTINE....)hakee kahdesta sarakkeesta. Esim.
Taulukon1 sarekkeessa A nimi, B ikä , C kunta.
Taulukon2 sarekkeessa A nimi, B ikä
Tee taulukkoon2 siihen sarakkeeseen mihin kunnan haluat, vaikka F1 kaava
{=INDEKSI(Taul1!$A$1:$D$20;VASTINE(A1&B1;Taul1!$A$1:$A$20&Taul1!$B$1:$B$20;0);3)}
ja vedät muihin F-sarakkeen soluihin
{=INDEX(Taul1!$A$1:$D$20;MATCH(A1&B1;Taul1!$A$1:$A$20&Taul1!$B$1:$B$20;0);3)}
Kiitokset!
Minulla varmaan joku pikku juttu jäänyt huomaamatta, kun kaava ei anna kirjoituksen jälkeen mitään tulosta, vaan jää soluun näkyviin kaavana. Mikä lienee syynä? Sain pelaamaan modulin kautta, joten kaikki ok!
kyllä Paavalin kaava toimii...
moduuliin...
Option Explicit
Sub HaeJaSiirrä()
Dim vika As Integer
Dim i As Integer
Dim ehto1 As String
Dim ehto2 As String
Dim KopioAlue As Range
On Error Resume Next
Application.ScreenUpdating = False
vika = Range("Taul2!A65536").End(xlUp).Row
Range("Taul2!F2:G" & vika) = ""
For i = 2 To vika
Sheets("Taul2").Activate
vika = Range("Taul2!A65536").End(xlUp).Row
ehto1 = Range("A" & i)
ehto2 = Range("B" & i)
Sheets("Taul1").Select
With Range("A:D")
.AutoFilter Field:=1, Criteria1:=ehto1
.AutoFilter Field:=2, Criteria1:=ehto2
End With
With Sheets("Taul1")
Set KopioAlue = .AutoFilter.Range.Offset _
(1, 2).Resize(.AutoFilter.Range.Rows.Count - 1, .AutoFilter.Range.Columns.Count - 2)
End With
KopioAlue.Copy Destination:=Range("Taul2!F" & i)
Next
Cells.AutoFilter
ActiveSheet.ShowAllData
Application.ScreenUpdating = True
End Sub
Suuret kiitokset, Kunde! Tuon kun lätkäisin moduliin, niin vot! Todella hieno juttu! Mutta, tietenkin hinku yltyy...Edellisessä tapauksessa sheet1:den sarakkeissa A ja B sijaitsivat hakuehdot joidenka mukaan C ja D puolestaan siirrettiin oikeille kohdille Sheet2:teen. Toisessa aineistossa Sheet1:llä on hakuehtoja 4 sarakkeessa (A:D) ja siirrettävät tiedot ovat E ja F sarakkeissa. Sheet2:lta löytyy jälleen vastaavat sarakkeet ja tiedot A-D osalta ja nuo E ja F pitäisi siirtää sinne oikeille kohdilleen. Koitin sorvata tuota koodiasi, mutta eihän se toiminut, kun ei osaa! Eli kuten edellinen, nyt vain hakuehtoja olisi kahden sijasta neljä kappaletta. Ohessa väännös, lisätyt hakuehdot eivät toimi, voisitko ystävällisesti korjata puutteet!
Option Explicit
Sub HaeJaSiirrä()
Dim vika As Integer
Dim i As Integer
Dim ehto1 As String
Dim ehto2 As String
Dim ehto3 As String
Dim ehto4 As String
Dim KopioAlue As Range
On Error Resume Next
Application.ScreenUpdating = False
vika = Range("Sheet2!A65536").End(xlUp).Row
Range("Sheet2!H2:I" & vika) = ""
For i = 2 To vika
Sheets("Sheet2").Activate
vika = Range("Sheet2!A65536").End(xlUp).Row
ehto1 = Range("A" & i)
ehto2 = Range("B" & i)
ehto3 = Range("C" & i)
ehto4 = Range("D" & i)
Sheets("Sheet1").Select
With Range("A:F")
.AutoFilter Field:=1, Criteria1:=ehto1
.AutoFilter Field:=2, Criteria1:=ehto2
.AutoFilter Field:=3, Criteria1:=ehto3
.AutoFilter Field:=4, Criteria1:=ehto4
End With
With Sheets("Sheet1")
Set KopioAlue = .AutoFilter.Range.Offset _
(1, 2).Resize(.AutoFilter.Range.Rows.Count - 1, .AutoFilter.Range.Columns.Count - 2)
End With
KopioAlue.Copy Destination:=Range("Sheet2!H" & i)
Next
Cells.AutoFilter
ActiveSheet.ShowAllData
Application.ScreenUpdating = True
End Sub
Kiitokset
lähellä olit! ja kiitoksia
koska lisäsit 2 saraketta muuttui alue 6 sarakkeen levyiseksi ja kun tarvitsemme vain kaksi, niin aluetta pitää nyt pienentää 4 saraketta ja vastaavasti alueen vasempaan reunaan on nyt matkaa 4 saraketta solusta A1 (offset on 0-pohjainen)
joten korjattavaa ei ollut paljoa
Set KopioAlue = .AutoFilter.Range.Offset _
(1, 4).Resize(.AutoFilter.Range.Rows.Count - 1, .AutoFilter.Range.Columns.Count - 4)
Tämä Offset/Resize on kyllä makee yhdistelmä :-)
Option Explicit
Sub HaeJaSiirrä()
Dim vika As Integer
Dim i As Integer
Dim ehto1 As String
Dim ehto2 As String
Dim ehto3 As String
Dim ehto4 As String
Dim KopioAlue As Range
On Error Resume Next
Application.ScreenUpdating = False
vika = Range("Sheet2!A65536").End(xlUp).Row
Range("Sheet2!H2:I" & vika) = ""
For i = 2 To vika
Sheets("Taul2").Activate
vika = Range("Sheet2!A65536").End(xlUp).Row
ehto1 = Range("A" & i)
ehto2 = Range("B" & i)
ehto3 = Range("C" & i)
ehto4 = Range("D" & i)
Sheets("Sheet1").Select
With Range("A:F")
.AutoFilter Field:=1, Criteria1:=ehto1
.AutoFilter Field:=2, Criteria1:=ehto2
.AutoFilter Field:=3, Criteria1:=ehto3
.AutoFilter Field:=4, Criteria1:=ehto4
End With
With Sheets("Sheet1")
Set KopioAlue = .AutoFilter.Range.Offset _
(1, 4).Resize(.AutoFilter.Range.Rows.Count - 1, .AutoFilter.Range.Columns.Count - 4)
End With
KopioAlue.Copy Destination:=Range("Sheet2!H" & i)
Next
Cells.AutoFilter
ActiveSheet.ShowAllData
Application.ScreenUpdating = True
End Sub