kunde

Vapaa kuvaus

Isaan Rules WFF CCC If you walked away smiling-then for you the price was right Keep Exceling Suosikkibändit/artistit: Queen, Rammstein, genesis, Bruce Bringsteen, Kino, Mandref Mann Earth band Who Lempikirjat: ohjelmointi... Suosikkipalstat Suomi24 Keskusteluissa: EXCEL, Kivitalot, EPS En pidä: pakkanen ja loskakelit Ruoka & juoma: loimulohi ja valkkari Linkit: http://www.kundepuu.com, Khorat Koulutus: --- Ammatti: Tiede/teknologia Työskentelen: freelancer Ase tai siviilipalvelus: yliluutnantti Siviilisääty: Varattu Lapset: --- Hakusanat: Thaimaa, korat, Excel, VBA, ACAD, CNC, Polyurea, EPS, MgO elementti

Aloituksia

7

Kommenttia

1374

  • Uusimmat aloitukset
  • Suosituimmat aloitukset
  • Uusimmat kommentit
  1. Pikku viilausta ....


    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A11:A12")) Is Nothing Then
    Target = UCase(Target)
    End If
    If Not Intersect(Target, Range("A13: A14")) Is Nothing Then
    Target = StrConv(Target, vbProperCase)
    End If
    End Sub


    Keep EXCELing
    @Kunde
  2. Sorry mun webbisivut päivittämättä muitten kiireiden takia. Yritän saada ne ajan tasalle keväämmällä ilmoittelen sitten...
  3. ko. taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A11")) Is Nothing Then
    Range("A11") = UCase(Range("A11"))
    End If
    If Not Intersect(Target, Range("A12")) Is Nothing Then
    Range("A12") = StrConv(Range("A12"), vbProperCase)
    End If
    End Sub


    Keep EXCELing
    @Kunde
  4. jos solussa A13 on kelpoisuusehtona lista, jossa 2 jäsentä Avoinna ja Suljettu
    Koodin pätkä Range("A11:A13").ClearContents tai Range("A11:C13") = "" tyhjentää solut
    Ja kun solua A13 klikkaa niin valinnat(Avoinna ja Suljettu) on käytössä.

    Mitenkäs se "lista" on tehty soluun A13?

    Keep EXCELing
    @Kunde
  5. en tajunnut pätkääkään...
  6. "nuo ~- merkit on soluissa (ei kylläkään välilyöti...) voit ne poistaa lisäämällä koodiin replace funktion millä korvaat ~- merkit välilyönneiksi
    esim. Replace(Suodatin, "~", " ")"

    Function Pikasuodatus(Alue As Range) As String
    Dim Suodatin As String
    Suodatin = ""
    On Error GoTo Poistu
    Application.Volatile True
    With Alue.Parent.AutoFilter
    If Not Intersect(Alue, .Range) Is Nothing Then
    With .Filters(Alue.Column - .Range.Column + 1)
    If .On Then
    Suodatin = Mid(.Criteria1, 2)
    Select Case .Operator
    Case xlAnd
    Suodatin = Mid(Suodatin & " JA " & .Criteria2, 2)
    Case xlOr
    Suodatin = Mid(Suodatin & " TAI " & .Criteria2, 2)
    End Select

    Else
    Suodatin = "KAIKKI"
    End If
    End With
    End If
    End With
    Poistu:
    Pikasuodatus = Replace(Suodatin, "~", " ")
    End Function

    Keep EXCELing
    @Kunde
  7. Function Pikasuodatus(Alue As Range) As String
    Dim Suodatin As String
    Suodatin = ""
    On Error GoTo Poistu
    Application.Volatile True
    With Alue.Parent.AutoFilter
    If Not Intersect(Alue, .Range) Is Nothing Then
    With .Filters(Alue.Column - .Range.Column + 1)
    If .On Then
    Suodatin = Mid(.Criteria1, 2)
    Select Case .Operator
    Case xlAnd
    Suodatin = Mid(Suodatin & " JA " & .Criteria2, 2)
    Case xlOr
    Suodatin = Mid(Suodatin & " TAI " & .Criteria2, 2)
    End Select

    Else
    Suodatin = "KAIKKI"
    End If
    End With
    End If
    End With
    Poistu:
    Pikasuodatus = Suodatin
    End Function

    "Myös välilyönnin kohdalle tulevat aaltoviivat ~ eivät ole toivottuja. Saako niitä poistettua? (esim d18 solun näkymä. =yy12 tai =yy12~)"

    nuo ~- merkit on soluissa (ei kylläkään välilyöti...) voit ne poistaa lisäämällä koodiin replace funktion millä korvaat ~- merkit välilyönneiksi
    esim. Replace(Suodatin, "~", " ")

    Keep EXCELing
    @Kunde
  8. toki tolla kaavalla saa muittenkin sarakkeiden suodatusehdot esille esim. viitaten edelliseen postaukseeni =Pikasuodatus(B2) näyttää sarakkeem B suodatusehdot....

    Keep EXCELing
    @Kunde
  9. ei tuo onnaa ilman koodia...
    D18 soluun kaava esim. jos haluamasi sarakkeen suodatusehtovalikko on solussa C2 =Pikasuodatus(C2)
    näyttää myös ja/tai ehdotkin ja jos ei ole mitään suodatusta niin KAIKKI teksti soluun D18...

    moduuliin...

    Function Pikasuodatus(Alue As Range) As String
    Dim Suodatin As String
    Suodatin = ""
    On Error GoTo Poistu
    Application.Volatile True
    With Alue.Parent.AutoFilter
    If Not Intersect(Alue, .Range) Is Nothing Then
    With .Filters(Alue.Column - .Range.Column + 1)
    If .On Then
    Suodatin = .Criteria1
    Select Case .Operator
    Case xlAnd
    Suodatin = Suodatin & " JA " & .Criteria2
    Case xlOr
    Suodatin = Suodatin & " TAI " & .Criteria2
    End Select

    Else
    Suodatin = "KAIKKI"
    End If
    End With
    End If
    End With
    Poistu:
    Pikasuodatus = Suodatin
    End Function

    Keep EXCELing
    @Kunde
  10. jollain maksullisilla sovellutuksilla ton voi ilmeisesti tehdäkin.
    Itse en ainakaan vielä ole löytänyt varmaa tapaa suojata tiedostoja. Jos teet sen makroilla, niin avatessa voit estää makrot ja suojaus on poissa. Toki voit ennen tiedoston sulkemista piilottaa kaikki taulukot ja jättää näkyville ns. etusivun ja siinä muistutuksen, että makrot on otettava käyttöön, jos et ota niin sulkee tiedoston.
    Niin vielä tohon aikarajoituksen kiertoohan riittää kun siirtää sitten käyttiksen kelloa taaksepäin..., toki sitäkin vaihtoehtoa voi tutkia ja jos kelloa on rukattu taaksepäin niin ei avaa tiedostoa...
    Monia kikkoja on, mutta ne kaikki on kierrettävissä melko helpostikin.
    Summa summarum hiukankin normikäyttäjää ovelampi keksii keinot kyllä, millä tiedoston saa avattua
  11. tekee aktiivisen taulukon A -sarakkeeseen listan uniikeista. Muuta polku ja tiedostojen nimet sopivaksi. Tiedostojen pitää olla muotoa testi1 ja testi2 tms.

    moduuliin...

    Sub UniikitTiedostosta()
    Dim i As Long
    Dim vika As Long
    For i = 1 To 2
    Workbooks.Open Filename:="c:\testi" & i & ".csv"
    ActiveSheet.UsedRange.Copy
    ActiveWorkbook.Close
    vika = Range("A65336").End(xlUp).Row
    Range("A" & vika).Select
    ActiveSheet.Paste
    Next i
    vika = Range("A65536").End(xlUp).Row
    For i = vika To 1 Step -1
    If Application.WorksheetFunction.CountIf(Range("A1:A" & i), Range("A" & i).Text) > 1 Then
    Range("A" & i).EntireRow.Delete
    End If
    Next i
    End Sub

    Keep EXCELing
    @Kunde
  12. Application.ScreenUpdating = False
    ...koodia
    Application.ScreenUpdating = True
  13. Sub EtsijaKorvaa()
    Dim polku As String
    Dim tiedosto As Variant
    Dim työkirja As Worksheet
    Dim haettava As String
    Dim korvattava As String
    On Error GoTo virhe
    haettava = ActiveSheet.Range("A1")
    korvattava = ActiveSheet.Range("A2")
    Application.ScreenUpdating = False
    polku = "C:\Testailua\"
    With Application.FileSearch
    .NewSearch
    .LookIn = polku
    .SearchSubFolders = False
    .Filename = ".xls"
    If .Execute > 0 Then
    For Each tiedosto In .FoundFiles
    Workbooks.Open tiedosto
    With ActiveWorkbook
    For Each työkirja In .Worksheets
    työkirja.Cells.Replace haettava, korvattava, xlWhole, , True
    Next
    .Close True
    End With
    Next
    End If
    End With
    virhe:
    Application.ScreenUpdating = True
    End Sub

    Keep EXCELing
    @Kunde
  14. moduuliin...
    vaihda tiedostopolku ja sanat sopiviksi...

    Sub EtsijaKorvaa()
    Dim polku As String
    Dim tiedosto As Variant
    Dim työkirja As Worksheet
    On Error GoTo virhe
    Application.ScreenUpdating = False
    polku = "C:\Testailua\"
    With Application.FileSearch
    .NewSearch
    .LookIn = polku
    .SearchSubFolders = False
    .Filename = ".xls"
    If .Execute > 0 Then
    For Each tiedosto In .FoundFiles
    Workbooks.Open tiedosto
    With ActiveWorkbook
    For Each työkirja In .Worksheets
    työkirja.Cells.Replace Volvo", "mersu", xlWhole, , True
    Next
    .Close True
    End With
    Next
    End If
    End With
    virhe:
    Application.ScreenUpdating = True
    End Sub

    Keep EXCELing
    @Kunde
  15. KIITOS
    The worst day with VBA is better than the best day at work!
  16. helppoahan se nyt oli kun sai selkeät ohjeet...
    fiksasin nyt vielä siten, että huomioi automaattisesti sarakkeiden määrän

    Sub Transponoi()
    Dim vika As Integer
    Dim vika2 As Integer
    Dim solu As Range
    Dim i As Integer
    Dim j As Integer
    Dim originaali As Worksheet
    Dim uusi As Worksheet
    Set originaali = ActiveSheet
    vika = Worksheets(originaali.Name).Range("A65536").End(xlUp).Row
    vika2 = Range("IV1").End(xlToLeft).Column
    Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    For Each solu In Worksheets(originaali.Name).Range("B2:B" & vika)
    solu.Resize(1, vika2).Copy
    Worksheets(taulukko.Name).Range("C65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    Next
    Range("A2").Select
    For i = 1 To vika - 1
    Worksheets(originaali.Name).Range("B1").Resize(1, vika2).Copy
    Worksheets(taulukko.Name).Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    Next
    For i = 1 To vika - 1
    For j = 1 To vika2 - 1
    Worksheets(originaali.Name).Range("A" & i + 1).Copy Worksheets(taulukko.Name).Range("A65536").End(xlUp).Offset(1, 0)
    Next
    Next
    Application.CutCopyMode = False
    End Sub

    Keep EXCELing
    @Kunde
  17. laita esimerkki kopioitavasta datasta ja miten se pitää saada uuteen taulukkoon, helpottaa suunnattomasti ;-)
  18. oletuksena otsikot ekalla rivillä ja 4 saraketta tietoa.
    helppo muutella toki...

    Sub Transponoi()
    Dim vika As Integer
    Dim solu As Range
    Dim originaali As Worksheet
    Dim uusi As Worksheet
    Set originaali = ActiveSheet
    vika = Worksheets(originaali.Name).Range("A65536").End(xlUp).Row
    Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    For Each solu In Worksheets(originaali.Name).Range("A2:A" & vika)
    solu.Resize(1, 11).Copy
    Worksheets(taulukko.Name).Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    Next
    Range("A2").Select
    For i = 1 To vika - 1
    Worksheets(originaali.Name).Range("A1:D1").Copy
    Worksheets(taulukko.Name).Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    Next
    Application.CutCopyMode = False
    End Sub

    Keep EXCELing
    @Kunde
  19. en tiedä ymmärsinkö oikein, ja mitä niistä koodeista olis pitänyt muokata(muokkasin nyt ekaa versiota)?
    Nyt aktiivinen taulukko kopioituu aina aina uuteen taulukkoon, joka lisätään loppuun

    "Lisäarvoa tulisi myös siitä, että taulukon sarakenimet kopioituisivat transponoitujen arvojen vasemmalla olevaan sarakkeeseen."
    Tota en ymmärtänyt...

    Sub Transponoi()
    Dim vika As Integer
    Dim solu As Range
    Dim originaali As Worksheet
    Dim uusi As Worksheet
    Set originaali = ActiveSheet
    vika = Worksheets(originaali.Name).Range("A65536").End(xlUp).Row
    Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    For Each solu In Worksheets(originaali.Name).Range("A1:A" & vika)
    solu.Resize(1, 11).Copy
    Worksheets(taulukko.Name).Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    Next
    Application.CutCopyMode = False
    End Sub

    Keep EXCELing
    @Kunde
  20. se lontoon versiossa...
    suomiversio
    =POIMI.TEKSTI(SOLU("tiedostonnimi");ETSI("]";SOLU("tiedostonnimi"))+1;255)
    21. 37 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt