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. 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..
  2. 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
  3. 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
  4. ei voi käyttää suodatusta.
    Mutta kikkaillahan aina voi...

    Keep Excelling
    @Kunde
  5. 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
  6. 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
  7. 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
  8. minkähänlainen se sun makros mahtaa olla, mitä pitäs muuttaa???
    tottahan voin tehdä omankin version, mutta mielenkiinnosta haluan nähdä sinunkin version....
  9. 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
  10. 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
  11. Illustrator export ja .PNG muto. Näyttäis aika hyvältä...
  12. 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
  13. "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
  14. 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
  15. hakusanoja etsijasiirrä haejasiirrä
    kirjoittaja kunde ja kymmeniä esimerkkejä ja melkeimpä suoran toimiva koodi
    Keep Excelling
    @Kunde
  16. 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
  17. 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
  18. taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim vika As Long
    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
    Range("A" & vika + 2).FormulaR1C1 = "=SUM(R[-21]C:R[-1]C)"
    Range("B" & vika + 2).FormulaR1C1 = "=SUM(R[-21]C:R[-1]C)"
    Range("C" & vika + 2).FormulaR1C1 = "=SUM(R[-21]C:R[-1]C)"
    'näyttää 5 viimeistä tietoa, muuta lukua
    Application.GoTo Range("A" & vika - 4), True
    Application.EnableEvents = True
    End Sub
  19. varmaan tarkoitus on siirtää samassa työkirjassa TAULUKKOON 2,3 jne eikä TYÖKIRJAAN 2,3 jne

    moduuliin...

    Sub Siirrä()
    Dim vika As Long
    Dim solu As Range
    Dim ws As Worksheet
    On Error Resume Next
    For Each ws In ActiveWorkbook.Worksheets
    If Not ws.Name = "Sheet1" Then
    ws.Range("A:B") = ""
    End If
    Next
    Worksheets("Sheet1").Activate
    vika = Range("B65336").End(xlUp).Row
    For Each solu In Range(("B1:B" & vika))
    Select Case UCase(solu)
    Case "A"
    If solu.Offset(0, 1) = 1 Then
    Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet2").Range("A65336").End(xlUp).Offset(1, 0)
    End If
    Case "B"
    If solu.Offset(0, 1) = 1 Then
    Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet3").Range("A65336").End(xlUp).Offset(1, 0)
    End If
    Case "C"
    If solu.Offset(0, 1) = 1 Then
    Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet4").Range("A65336").End(xlUp).Offset(1, 0)
    End If
    Case "D"
    If solu.Offset(0, 1) = 1 Then
    Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet5").Range("A65336").End(xlUp).Offset(1, 0)
    End If
    Case "E"
    If solu.Offset(0, 1) = 1 Then
    Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet6").Range("A65336").End(xlUp).Offset(1, 0)
    End If
    Case "F"
    If solu.Offset(0, 1) = 1 Then
    Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet7").Range("A65336").End(xlUp).Offset(1, 0)
    End If
    Case "G"
    If solu.Offset(0, 1) = 1 Then
    Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet8").Range("A65336").End(xlUp).Offset(1, 0)
    End If
    Case "H"
    If solu.Offset(0, 1) = 1 Then
    Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet9").Range("A65336").End(xlUp).Offset(1, 0)
    End If
    End Select
    Next
    End Sub
  20. EI, EI ja EI
    yleensä pyrin tekemään universaalisia koodeja, jotka toimivat pikku muutoksilla miten, missa ja milloin vaan...
    niin oli kyse tälläkin kertaa...

    ensin määritellään jotakin tietoa sisältävä solualue
    Set Solut = Range("A:A").SpecialCells(xlCellTypeConstants)

    alue saa tiedot Solut.Areas (kannattaa luke alueen määritykset ohjeesta (löytyyköhän?)- lyhyesti siis tyhjä solu solun ympärillä ):- )
    joka taas saa tiedot Range("A:A").SpecialCells(xlCellTypeConstants) (kaikki tietoa sisältävät solut sarakkeesta)

    For Each Alue In Solut.Areas
    eli kaikki yhtenäiset alueet sarakkeessa loopataan

    Vika = Range("B65336").End(xlUp).Offset(1).Row
    hakee viimeisen rivin sarakkeesta B

    Range("B" & Vika).Resize(, Alue.Count) = Application.Transpose(Alue)
    taasen määrittelee transponoitavan "kopioaluuen" oikean kokoiseksi lähde sarakkeesta

    ja lopuksi sitten poistetaan tyhjät rivit...

    eli jos tarve esim sarakkeelle K...

    Sub Transponoi()
    Dim Vika As Long
    Dim Alue As Range
    Dim Solut As Range
    On Error Resume Next
    Rows("1:1").Insert Shift:=xlDown
    Set Solut = Range("K:K").SpecialCells(xlCellTypeConstants)
    For Each Alue In Solut.Areas
    Vika = Range("L65336").End(xlUp).Offset(1).Row
    Range("L" & Vika).Resize(, Alue.Count) = Application.Transpose(Alue)
    Next Alue
    Rows("1:1").Delete
    Columns("K:K").Delete
    End Sub

    KEEP EXCELLING!
    @Kunde
    21. 41 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt