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

1377

  1. mokahan siinä on...
    oli väärässä paikkaa toi "näytä kaikki" koodirivi

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim vika As Integer
    Dim solu As Range

    On Error Resume Next
    vika = Range("C65336").End(xlUp).Row
    Application.EnableEvents = False

    If Not Intersect(Target, Range("C13")) Is Nothing Then
    ActiveSheet.ShowAllData
    If Target = "" Then
    Range("G13") = ""
    GoTo poistu
    End If
    Range("C13:G" & vika).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    For Each solu In Range("C14:C" & vika).SpecialCells(xlCellTypeVisible)
    If Not solu = Range("C13") Then
    solu.EntireRow.Hidden = True
    End If
    Next solu
    Range("G13") = ""
    End If
    If Not Intersect(Target, Range("G13")) Is Nothing Then
    ActiveSheet.ShowAllData
    If Target = "" Then
    Range("C13") = ""
    GoTo poistu
    End If
    Range("C13:G" & vika).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    For Each solu In Range("G14:G" & vika).SpecialCells(xlCellTypeVisible)
    If Not solu = Range("G13") Then
    solu.EntireRow.Hidden = True
    End If
    Next solu
    Range("C13") = ""
    End If
    poistu:
    Application.EnableEvents = True
    End Sub
  2. kokeiles koodissa seuraavaa
    klikkaa hiiren vaemmalla rivien välissä
    Private Sub Worksheet_Change(ByVal Target As Range)
    ...
    End Sub

    sitten klikkailet F8 ja tutkaile koodissa seuraavaa riviä. (Voi tän tehdä fiksumminkin , mutta hankala selittää...)
    Vie hiiri solu sanan päälle ja tsekkaa sen arvo samoin tee Range("C13") sanalle. Vertaile näytettyjä arvoja ja tutki mikä ero niillä on? Ettei vaan olisi ylimääräisiä merkkejä soluissa? Jos näin on niin sitten koodin trimmikomentoa tai pituuden tarkistusta yms...

    If Not solu = Range("C13") Then
  3. sillä voit suodattaa niitä lukuja C sarakkeessa samanlailla kuin kuukausilla G sarakkeessa- et sitä sitten näköjään tarvinnut... ;-)

    kiitos palautteesta!

    Keep Excelling
    @Kunde
  4. kuten kirjoitin
    1. Poista suodatus taulukosta
    2. Liitä koodi TAULUKON MODUULIIN
    3 .kirjoita soluihin C13 tai G13 hakuehtosi ja uniikit näkyy...
    kelpoisuusehto dsoluun G13 helpottaa kuukausien suodatusta... ja
    C13 sitten vaatii sen combon ja koodin..
  5. tarkista värien koodinumerot , jotta ovat oikeita. Nauhoita vaikka makro ja vaihda fontinväriä ja tarkista fontinvärikoodi numerot...

    soluun kaavaesim. =SummaVärillä(I1:I60)

    moduuliin...

    Function SummaVärillä(Alue As Range) As Double
    Dim solu As Range
    Application.Volatile True
    For Each solu In Alue
    If solu.Font.ColorIndex = 3 Or solu.Font.ColorIndex = 10 Then
    SummaVärillä = SummaVärillä + solu
    End If
    Next solu
    End Function

    Keep Excelling
    @Kunde
  6. Autofilter pois käytöstä...

    nyt kun solut C13 tai G13 muuttuu niin suodattaa uniikit solun mukaan. Jos solu tyhjä niin näyttää kaikki.
    Suodatussoluihinhan voisi tietenkin lisätä combon ja sen arvoiksi uniikit sarakkeesta ja näin ollen toimisi kuten suodatusnappikin...
    no siinä purtavaa sulle- varmasti palstalta löytyy mun koodinpätkä siihenkin, joten hakua peliin...
    G13 solussa voit käyttää vaikka KELPOISUUSEHTOA listan lähteeksi tammi;helmi;maalis jne.

    taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim vika As Integer
    Dim solu As Range

    On Error Resume Next
    ActiveSheet.ShowAllData
    vika = Range("C65336").End(xlUp).Row
    Application.EnableEvents = False

    If Not Intersect(Target, Range("C13")) Is Nothing Then
    If Target = "" Then
    Range("G13") = ""
    GoTo poistu
    End If
    Range("C13:G" & vika).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    For Each solu In Range("C14:C" & vika).SpecialCells(xlCellTypeVisible)
    If Not solu = Range("C13") Then
    solu.EntireRow.Hidden = True
    End If
    Next solu
    Range("G13") = ""
    End If
    If Not Intersect(Target, Range("G13")) Is Nothing Then
    If Target = "" Then
    Range("C13") = ""
    GoTo poistu
    End If
    Range("C13:G" & vika).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    For Each solu In Range("G14:G" & vika).SpecialCells(xlCellTypeVisible)
    If Not solu = Range("G13") Then
    solu.EntireRow.Hidden = True
    End If
    Next solu
    Range("C13") = ""
    End If
    poistu:
    Application.EnableEvents = True
    End Sub

    ' jos sattuu moka, niin toimintojen palautuskoodi alla

    Sub Resetoi()
    On Error Resume Next
    Application.EnableEvents = True
    ActiveSheet.ShowAllData
    End Sub
  7. ei voi käyttää suodatusta.
    Mutta kikkaillahan aina voi...

    Keep Excelling
    @Kunde
  8. moduuliin...

    Sub PiilotaTuplat()
    Dim vika As Integer
    vika = Range("C65336").End(xlUp).Row
    Range("C1:G" & vika).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    End Sub

    Sub NäytäKaikki()
    ActiveSheet.ShowAllData
    End Sub

    Keep Excelling
    @Kunde
  9. jos tota käytät, ei toimi, koska Alue määritelty väärin...
    mutta
    siis haluat, että B sarakkeessa tehdään haku kuukausilla(arvaus ;-)) ja näytetään uniikit?
    voiko tuloksen näyttää muualla kuin originaalipaikassa?
    käykö lomake?

    kerro lisää...

    Keep Excelling
    @Kunde
  10. n. 10 vuotta sain kivasti TEKES:ltä rahaa koodin pätkästäni...
    Ajat muuttuneet ja nyt muutamalla kympillä näkyy olevan tarjolla ohjelmia.
    Sahojen/leikkureiden mukanahan tulee yleensä omat ohjelmat.
    Kandee siis googlettaa ja ladata ilmaisia demoja ja valita itselleen sopivassa budjektissa oleva ohjelma. Halvimman ja kalleimman ohjelman välinen optimointitulos voi olla isokin, mutta luulisin tommosella 100-200 USD saavan jo kelpo softan. Turha uhrata tuhansia.
    Ja jos optimointi ei ole hyvä niin lisää jotain bulkkituotetta(jos semmosia on tuotannossa) täytteeksi nestaukseen ja tulos paranee huomattavasti yleensä (ilmainen vinkki!) - niin sitä tehdään kalliimmillakin CAD/CAM ohjelmilla
  11. minkähänlainen se sun makros mahtaa olla, mitä pitäs muuttaa???
    tottahan voin tehdä omankin version, mutta mielenkiinnosta haluan nähdä sinunkin version....
  12. olinpas lukenut huolimattomasti kyssärin...
    kopioi oikealle
    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A1")) Is Nothing Then
    Select Case Target
    Case 27
    Target.Offset(0, 1) = 24
    Case 35
    Target.Offset(0, 1) = 30
    Case 66
    Target.Offset(0, 1) = 60
    'JNE..
    Case Else
    Target.Offset(0, 1) = Target
    End Select
    End If
    End Sub

    ja alaspäin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A1")) Is Nothing Then
    Select Case Target
    Case 27
    Target.Offset(1, 0) = 24
    Case 35
    Target.Offset(1, 0) = 30
    Case 66
    Target.Offset(1, 0) = 60
    'JNE..
    Case Else
    Target.Offset(1, 0) = Target
    End Select
    End If
    End Sub
  13. taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A1")) Is Nothing Then
    Select Case Target
    Case 27
    Target = 24
    Case 35
    Target = 30
    Case 66
    Target = 60
    'JNE..
    Case Else
    End Select
    End If
    End Sub
  14. Illustrator export ja .PNG muto. Näyttäis aika hyvältä...
  15. Function EtsiJaSiirrä2(Hakuehto As Variant) As Range

    Dim solu As Range
    Dim EkaOsoite As String
    Worksheets("Sheet1").Activate
    With Range("G:G")
    Set solu = .Find( _
    What:=Hakuehto, _
    LookIn:=xlValues, _
    LookAt:=xlWhole, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, _
    MatchCase:=False, _
    SearchFormat:=False)
    If Not solu Is Nothing Then
    Set EtsiJaSiirrä2 = solu
    EkaOsoite = solu.Address
    Do
    Set EtsiJaSiirrä2 = Union(EtsiJaSiirrä2, solu)
    Set solu = .FindNext(solu)
    Loop While Not solu Is Nothing And solu.Address EkaOsoite
    End If
    End With
    End Function

    Sub Testi2()
    Dim Löydetty As Range
    Dim solu As Range
    On Error GoTo virhe
    Set Löydetty = EtsiJaSiirrä2("Nok")
    For Each solu In Löydetty
    Union(solu.Offset(0, -6), solu.Offset(0, -5), solu.Offset(0, -4)).Copy Range("Sheet2!A65536").End(xlUp).Offset(1, 0)
    Next
    Exit Sub
    virhe:
    MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
    End Sub
  16. "ei tietoa, liittynee jotenkin duplikaatteihin...."
    varmaankinliittyy tupliin- 555 hahaha ;-)

    moduuliin...

    muuta sarake oikeaksi nyt A-sarake
    eka koodinpätkä piilottaa tuplat ja toka palauttaa kaikki...

    Sub PiilotaTuplaRivit()
    Dim vika As Long
    Dim i As Long
    vika = Range("A65536").End(xlUp).Row
    For i = vika To 1 Step -1
    If Application.WorksheetFunction.CountIf(Range("A1:A" & i), Range("A" & i)) > 1 Then
    Range("A" & i).EntireRow.Hidden = True
    End If
    Next i

    End Sub
    Sub NäytäKaikki()
    Rows.Hidden = False
    End Sub
  17. palauttaa // välissä olevan luvun
    =MID(E7;FIND("/";E7;1)+1;FIND("/";E7;FIND("/";E7;1)+1)-FIND("/";E7;1)-1)
    =LEFT(REPLACE(E7;1;F7;"");FIND("/";REPLACE(E7;1;F7;"");1)-1)

    koodaamalla tietenkin ja kuten tuttumies mainitsi teksti sarakkeisiin
  18. hakusanoja etsijasiirrä haejasiirrä
    kirjoittaja kunde ja kymmeniä esimerkkejä ja melkeimpä suoran toimiva koodi
    Keep Excelling
    @Kunde
  19. soluun mihin haluat tuloksen esim. solusta C2 =Erottele(C2)

    ja moduuliin...
    (virhetarkastelu puuttuu kun ei tarkempaa selostusta tarpeista) antaa nyt virheilmoituksen kun solu on tyhjä tai sarjassa ei ole numeroa alussa.

    Function Erottele(txt As String) As Variant
    If IsNumeric(txt) Then
    Erottele = Val(txt)
    Exit Function
    End If
    With CreateObject("VBScript.RegExp")
    .Pattern = "-?\d+"
    Erottele = .Execute(txt)(0)
    Erottele = Erottele & " " & Mid(Range("C2"), Len(Erottele) + 1)
    End With
    End Function
  20. oikeasti vaikka näin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim vika As Long
    Dim kaava As String
    On Error Resume Next
    Application.EnableEvents = False
    vika = Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Row
    Range("A" & vika).EntireRow = ""
    vika = Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Row
    kaava = "A1:A" & vika
    Range("A" & vika + 2).Formula = "=SUM(" & kaava & ")"
    kaava = "B1:B" & vika
    Range("B" & vika + 2).Formula = "=COUNTA(" & kaava & ")"
    kaava = "C1:C" & vika
    Range("C" & vika + 2).Formula = "=AVERAGE(" & kaava & ")"
    'näyttää 5 viimeistä tietoa, muuta lukua
    Application.GoTo Range("A" & vika - 4), True
    Application.EnableEvents = True
    End Sub
    21. 41 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt