Morjensta,
Tarvis tehdä exceliin macro, jolla pystyisi kopiomaan ja lajittelemaan yhdeltä välilehdeltä tietyt ehdot täyttäviä rivejä toisille välilehdille. Lähde välilehti voisi näyttää esim tältä:
C D E F
5 ha audi a4 1,8
6 mp audi x1 1,6
7 ha audi a3 2
8 pa toyota dyna 2,4
9 pa toyota hiace 2,6
Ja lopputuloksena olisi seuraavanlaiset välilehdet:
Audi henkiloautot-välilehti
B C D
3 1,8 audi a4
4 2 audi a3
Toyota pakettiautot-välilehti:
B C D
3 2,4 toyota dyna
4 2,6 toyota hiace
Macro siis tarkastaisi lähde välilehden sarakkeet C ja D ja jos ne kelpaavat, kopioidaan rivi oikealle välilehdelle, ja vielä siten että sarakkeiden paikka on vaihtanut. Minkälaisella koodilla tulisi lähteä liikkeelle?
Entäpä sitten kun merkkejä ja malleja on monta kappaletta? Tuleeko jokaiselle merkille oma välilehti? Toimisiko Excelin oma suodatus paremmin, koska sen voi tehdä jokaisen otsikon mukaisesti. Ainakin siis 2007 versiossa vanhemmista en ole varma.
No jos näitä vaihtoehtoja ei olisi kuin muutama..
En näe kyllä tuossa alkuperäisen idean mukaisessa toteutuksessa mitään ihmeempiä ongelmia.
Eli:
- looppaa alkuperäisen lehden rivit läpi
- valitse merkkiä ja tyyppiä vastaava lehti, jos ei, lisää ja valitse uusi
- kopioi rivin tiedot valitun lehden ensimmäiselle tyhjälle riville.
Tai toinen vaihtoehto:
- Sorttaa alkuperäiset tiedot
- Looppaa rivit läpi
- jos merkki ja tyyppi eri kuin edellisellä rivillä, tee uusi lehti
- kopioi rivi lehdelle
Tällaisen koodin pätkän löysin aikaisemmista viestiketjuista. Saisko tästä jotenkin muokattua tähän käyttöön sopivan. Ohjelmointitaitoni, kun ovat "hieman" hukassa?
Private Sub CommandButton1_Click()
Dim taulu, solu
Application.ScreenUpdating = False
Sheets("Taul3").Range("A1:" + Sheets("Taul3"). _
Cells.SpecialCells(xlCellTypeLastCell).Address).Select
Selection.Clear
For Each taulu In Sheets
If taulu.Name <> "Taul3" Then
For Each solu In taulu.Range("A1:A" + _
CStr(taulu.Cells.SpecialCells(xlCellTypeLastCell).Row))
If solu.Value = "Matti" Then
i = i + 1
taulu.Range("A" + CStr(solu.Row) + ":D" + _
CStr(solu.Row)).Copy Destination:=Sheets( _
"Taul3").Range("A" + CStr(i) + ":D" + CStr(i))
End If
Next
End If
Next
Application.ScreenUpdating = True
End SubMoikka kemospetrol!
oheinen esimerkki mukailee alkuperäisen kysymyksesi mallia...
Private Sub CommandButton1_Click()
Dim taulu, solu
Dim rivit, merkki, luokka, vlehti
'"Kaikki autot" on lähdetaulun nimi
rivit = Sheets("Kaikki autot").UsedRange.Cells. _
SpecialCells(xlCellTypeLastCell).Row
For Each solu In Sheets("Kaikki autot").Range("D1:D" + CStr(rivit))
luokka = ""
Select Case solu.Value
Case "ha": luokka = "henkilöautot"
Case "pa": luokka = "pakettiautot"
'jne.
End Select
If luokka <> "" Then
Dim alku, loppu, rivix
merkki = Cells(solu.Row, 5).Value
alku = UCase(Left(merkki, 1))
loput = LCase(Right(merkki, Len(merkki) - 1))
vlehti = alku + loput + " " + luokka
rivix = Sheets(vlehti).UsedRange.Cells. _
SpecialCells(xlCellTypeLastCell).Row
If rivix < 3 Then
rivix = 3
Else
rivix = rivix + 1
End If
Sheets(vlehti).Cells(rivix, 2).Value = _
Cells(solu.Row, 7).Value
Sheets(vlehti).Cells(rivix, 3).Value = _
Cells(solu.Row, 5).Value
Sheets(vlehti).Cells(rivix, 4).Value = _
Cells(solu.Row, 6).Value
End If
Next
End SubMoikka taas kemospetrol!
tässä vielä samaa tarkistusrutiinilla & kommentoituna
Private Sub CommandButton1_Click()
' alustetaan muuttujat (Variant-tyyppisiksi)
Dim taulu, solu
Dim rivit, merkki, luokka, vlehti
' poimitaan lähdetaulun käytössä olevan
' alueen viimeisen rivin indeksiarvo
' ja sijoitetaan arvo muuttujaan 'rivit'
rivit = Sheets("Kaikki autot").UsedRange.Cells. _
SpecialCells(xlCellTypeLastCell).Row
' käydään silmukassa läpi kaikki lähdetaulun
' C sarakkeen solut ensimmäiseltä riviltä
' käytössä olevan alueen viimeiselle riville
For Each solu In Sheets("Kaikki autot"). _
Range("C1:C" + CStr(rivit))
' asetetaan jokaisella kierroksella
' merkijonomuuttujan 'luokka' arvoksi
' tyhjä merkkijono
luokka = ""
' annetaan ehtolauserakennelmassa
' arvo muuttujalle 'luokka', muuttujan
' 'solu' kulloisenkin arvon perusteella
Select Case solu.Value
Case "ha": luokka = "henkilöautot"
Case "pa": luokka = "pakettiautot"
'jne.
End Select
' jos muuttujan 'luokka' arvoksi on saatu
' muu kuin tyhjä merkkijono niin...
If luokka <> "" Then
'alustetaan lisää muuttujia
Dim alku, loppu, rivix, vertaa
merkki = Cells(solu.Row, 4).Value
' poimitaan merkkijonosta 'merkki' ensimmäinen
' merkki, muutetaan isoksi kirjaimeksi
' ja sijoitetaan arvo muuttujaan 'alku'
alku = UCase(Left(merkki, 1))
' pomitaan samasta merkkijonosta loput
' merkit, muutetaan pieniksi kirjaimiksi
' ja sijoitetaan arvo muuttujaan 'loput'
loput = LCase(Right(merkki, Len(merkki) - 1))
' sijoitetaan merkkijonojen yhdistelmä
' muuttujan 'vlehti' arvoksi, jolloin
' muutujan arvoa voidaan käyttää viitatessa
' nimellä välilehteen (= Työkirjan taulu)
vlehti = alku + loput + " " + luokka
' poimitaan kohdetaulun käytössä olevan
' alueen viimeisen rivin indeksiarvo
' ja sijoitetaan muuttujan 'rivix' arvoksi
rivix = Sheets(vlehti).UsedRange.Cells. _
SpecialCells(xlCellTypeLastCell).Row
' alustetaan boolean-tyyppinen muuttuja
Dim taulussa As Boolean
'tarkistetaan onko lähdetaulusta kulloinkin
'poimittavat tiedot jo mahdollisesti kohdetaulussa
For i = 1 To rivix
If Sheets(vlehti).Cells(i, 2) = _
Cells(solu.Row, 6).Value _
And Sheets(vlehti).Cells(i, 3) = _
Cells(solu.Row, 4).Value And _
Sheets(vlehti).Cells(i, 4) = _
Cells(solu.Row, 5).Value Then
' ja jos ovat niin asetetaan
' boolean muuttujan arvoksi TOSI
' ja poistutaan silmukasta
taulussa = True: Exit For
End If
Next i
' Jos muuttujan arvo on EPÄTOSI...
If Not taulussa Then
' ja kohdetaulun käytössä olevan
' alueen viimeinen rivi < 3
If rivix < 3 Then
' asetetaan viimeistä riviä
' osittavan muuttujan arvoksi 3
rivix = 3
Else
' muutoin kasvatetaan muuttujan arvoa
' yhdellällä (viimeinen rivi + 1)
rivix = rivix + 1
End If
' ja sijoitetaan lähdetaulusta muuttujan 'solu'
' sisältämän rivi-indeksin ja suoran sarakeindeksi-
' viitauksen avulla tiedot kohdetaulussa haluttuhin
' sarakkeisiin muuttujan 'rivix' osoittamalle riville
' käyttäen suoraa sarakeindeksiviittausta
Sheets(vlehti).Cells(rivix, 2).Value = _
Cells(solu.Row, 6).Value
Sheets(vlehti).Cells(rivix, 3).Value = _
Cells(solu.Row, 4).Value
Sheets(vlehti).Cells(rivix, 4).Value = _
Cells(solu.Row, 5).Value
End If
End If
Next
End SubMorjensta Nea
Kiitoksia avuista ja yksityiskohtaisesta koodin salojen selostuksesta. En kuitenkaan saa tällä Macroa toimimaan.. Saan virhe ilmoituksen:
Run-time error '9': subscript out of range
ja debugger jymähtää kohtaan:
rivix = Sheets(vlehti).UsedRange.Cells. _
SpecialCells(xlCellTypeLastCell).Row
Mikähän avuksi?
Ähh.. kyllähän tuo toimii niinkuin on tarkoitettukin, käyttäjässä vain taitaa hieman olla. Tuli hitusen muutoksia alkuperäiseen taulukkoon. Mites saisin tälläisen "kaikki autot" -syötesivun lajiteltua uusille välilehdille:
B C D E
3 x x audi automaatti
4 x skoda automaatti
5 x x ww automaatti
6 x x mb automaatti
7 x fiat manuaali
8 x x fiat manuaali
9 x x audi manuaali
10 x x alfa automaatti
siten että, jos sarakkeissa B ja C olevat ruksilla merkityt kummatkin lisävarusteet löytyvät kopioidaan ja lajitellaan auton tiedot (merkki ja vaihteiston tyyppi) vaihteiston tyypin perusteella omille välilehdille "automaatti" ja "manuaali" siten että automerkit tulee välilehdille aakkosjärjestyksessä.
Aihe on jo aika vanha, joten et voi enää vastata siihen.