omien havaintojen lataus

[PekkaS]

... lisätieto-kentistä hävisi pisteet.... Lisäksi yhdessä havainnossa, missä oli syötetty eri riveille pariutuneet emot ja toiselle maastopoikaset, oli kopioitunut myös poikasille tuo 'pariutuneet'....
t: JaniV

Tässä korjaus, joka poistaa pisteiden häviämiseen liittyvän ongelman. Jälkimmäinen virhe on korjattu jo aiemmin, eli käytössäsi ei ollut tuorein versio.

- PekkaS-

Sub TIIRAN_HAVIKSET_TYHJIENSOLUJENTAYTTO()
'Versio 1.02 10.12.2007
'
'Lauri Nikkinen 20.7.2006
'Sarkealueen rajaus Pekka Suopajärvi 10.8.2006
'Lisätietopisteiden poisto korjattu Pekka Suopajärvi 10.12.2007
'
'Makro olettaa, että täytettävät solut alkavat laji-muuttujasta, joka on saraakkeessa B ja päättyät salaus-muuttujaan sarakkeessa R

Range("B1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="<>"
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "."
Selection.AutoFilter Field:=2

Do
'Hakee B1-sarakkeesta ensimmäisen solun, joka on ennen tyhjää solua
Range("B1").End(xlDown).Select

'Valitsee täytettävän solualueen
Set LeftCell = Cells( ActiveCell.Row, 2)
Set RightCell = Cells(ActiveCell.Row, 256)

If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight)
If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft)
If LeftCell.Column = 256 And RightCell.Column = 2 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select
Range(Selection, Selection.End(xlDown)).Select

'Solualueen täyttö

'Tämän kohdan koodaajat alla
'Tom Ogilvy, 1999/12/14 programming
'Revised David McRitchie, 2000-11-25 programming
Application.ScreenUpdating = False
Application.Calculation = xlManual
Dim cell As Range
For Each cell In Intersect(Selection, _
ActiveSheet.UsedRange )
' Täyttää vain sarakkeeseen 18 (R) saakka
If Trim(cell) = "" And cell.Row > 1 And cell.Column <= 18 Then
cell.NumberFormat = cell.Offset(-1, 0).NumberFormat
cell.Value = cell.Offset(-1, 0).Value
End If
Next cell
Application.Calculation = xlAutomatic 'xlCalculationAutomatic
Application.ScreenUpdating = False

'Looppi kunnes tulee tyhjä solu A-sarakkeessa
Loop Until IsEmpty(ActiveCell.Offset (1, 0))

Cells.Replace What:=".", Replacement:="", LookAt:=xlWhole, SearchOrder:= _
xlByRows, MatchCase:=False
Selection.AutoFilter
Cells(1, 1).Select
End Sub

[AAa]

Moi!

Koitin tuossa juuri äsken viimeisimmällä makrolla käydä läpi kaikki omat havaintoni, jotka näin ennen massasyöttöaikaa Tiirassa ovat (n. 5000 riviä), ja ongelmiahan siitä seurasi:

Noin 2/3 lisätieto-1 kentän tiedoista hyppeli aivan minne sattuu, mutta osa oli sitten ihan oikeilla paikoillaan. Esimerkiksi vuoden 2006 puukiipijähavaintoon hyppäsi vuoden 2008 valkoselkätikan lisätiedot ym ilman mitään heti näkyvää logiikkaa.

Missähän vika, makrossa, excelissä vai mitä ilmeisimmin käyttäjässä? :)

/Ari

[KalleR]

Moi!

Koitin tuossa juuri äsken viimeisimmällä makrolla käydä läpi kaikki omat havaintoni, jotka näin ennen massasyöttöaikaa Tiirassa ovat (n. 5000 riviä), ja ongelmiahan siitä seurasi:

Noin 2/3 lisätieto-1 kentän tiedoista hyppeli aivan minne sattuu, mutta osa oli sitten ihan oikeilla paikoillaan. Esimerkiksi vuoden 2006 puukiipijähavaintoon hyppäsi vuoden 2008 valkoselkätikan lisätiedot ym ilman mitään heti näkyvää logiikkaa.

Missähän vika, makrossa, excelissä vai mitä ilmeisimmin käyttäjässä? :)

/Ari

Moi,
ajoin äsken makron hiukka yli 9000 havainnon satsilla, lisätiedot näyttivät menevän oikein. Nää oli tosin kaikki yhdeltä kevätkaudelta.

KORJAUS: katsoinkin rivikohtaisia lisätietoja, jotka meni oikein. Varsinainen lisätieto taasen kopoitui usein myös seuraaviin havaintoihin.

Voiko uudella excelin versiolla olla jotain tekemistä ongelmien kanssa?

Kalle Rainio

[AAa]

Moi!

Eipä varmaan voi, sillä menee pieleen tuolla meidän pöytäkoneellakin, jossa on vanha excel.

Mahtaakohan kukaan tietää mistä johtuu, että voisi joskus saada omat havikset nätisti ulos? :)

/Ari

[PekkaS]

Koodissa tosiaan oli virhe, jonka seurauksena lisätietoja kopioitui vähän turhan monelle riville... Tässä korjattu versio.

Koodi: Valitse kaikki

Sub TIIRAN_HAVIKSET_TYHJIENSOLUJENTAYTTO()
'Versio 1.03 10.2.2009
'
'Lauri Nikkinen 20.7.2006
'Sarkealueen rajaus Pekka Suopajärvi 10.8.2006
'Lisätietopisteiden poisto korjattu Pekka Suopajärvi 10.12.2007
'Lisätietojen kopionti väärille riveille korjattu Pekka Suopajärvi 10.2.2009
'
'Makro olettaa, että täytettävät solut alkavat laji-muuttujasta, joka on saraakkeessa B ja päättyät salaus-muuttujaan sarakkeessa R

Range("B1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="<>"
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "."
Selection.AutoFilter Field:=2

Do
'   Hakee B1-sarakkeesta ensimmäisen solun, joka on ennen tyhjää solua
    Range("B1").End(xlDown).Select
    
'   Valitsee täytettävän solualueen
    Set LeftCell = Cells(ActiveCell.Row, 2)
    Set RightCell = Cells(ActiveCell.Row, 256)
    
    If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight)
    If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft)
    If LeftCell.Column = 256 And RightCell.Column = 2 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select
    Range(Selection, Selection.End(xlDown)).Select
    
'   Solualueen täyttö
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Dim cell As Range

'   For-Each idean koodaajat alla
'   Tom Ogilvy, 1999/12/14 programming
'   Revised David McRitchie, 2000-11-25 programming
    For Each cell In Intersect(Selection, _
        ActiveSheet.UsedRange)

'       Täyttää vain jos lajisarake on tyhjä
        If cell.Column = 2 Then
            If Trim(cell) = "" Then
                emptyRow = 1
            Else
                emptyRow = 0
            End If
        End If
        
'       Täyttää vain sarakkeeseen 18 (R) saakka
        If emptyRow = 1 And Trim(cell) = "" And cell.Row > 1 And cell.Column <= 18 Then
            cell.NumberFormat = cell.Offset(-1, 0).NumberFormat
            cell.Value = cell.Offset(-1, 0).Value
        End If
    Next cell
    
    Application.Calculation = xlAutomatic 'xlCalculationAutomatic
    Application.ScreenUpdating = False
    
 '  Looppi kunnes tulee tyhjä solu A-sarakkeessa
Loop Until IsEmpty(ActiveCell.Offset(1, 0))

Cells.Replace What:=".", Replacement:="", LookAt:=xlWhole, SearchOrder:= _
xlByRows, MatchCase:=False
Selection.AutoFilter
Cells(1, 1).Select
End Sub

[mikko]

Parantelin vanhaa Tiira-KML -muunnostyökaluani niin, että se osaa muuntaa Tiira-datan myös tekstitiedostoksi (sarkaimilla erotetut sarakkeet). Työkalu ja lähdekoodi (PHP) ovat osoitteessa http://www.biomi.org/linnut/tiira.html

Muunnos toimii suoraan www-selaimessa, eikä Exceliä tarvita. Palautetta toiminnasta voi lähettää ko. sivulla tai tänne foorumiin.