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. 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
  2. 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
  3. 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
  4. SAPista
    villi arvaus
    normaalistihan Excelissä se menee näin
    1. lisää VBA puolella Tools... References viittaus ohjelmaan ( SAP) objekti kirjastoon
    2. koodissa sitten jotain tämmöstä...
    Set SAP = CreateObject("SAP.Application")
    ja sitten tsekkaat mitä jutskia on käytetävissä vai onko mitään... );-

    javascript:void(0);
  5. ei väliä sarjojen pituudella eikä sillä miten monta tyhjää välissä
    pitäisi tietenkin tyhjentää noi oikealla olevat sarakkeet ekaksi vanhoista tiedoista, mutta jääköön se kysyjän tehtäväksi
    moduuliin...

    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("A:A").SpecialCells(xlCellTypeConstants)
    For Each Alue In Solut.Areas
    Vika = Range("B65336").End(xlUp).Offset(1).Row
    Range("B" & Vika).Resize(, Alue.Count) = Application.Transpose(Alue)
    Next Alue
    Rows("1:1").Delete
    Columns("A:A").Delete
    End Sub

    Keep Excelling
    @Kunde
  6. nimen voit lisätä kaavarivin vasemmalla olevaan nimiruutuun kirjoittamalla haluamasi nimen ja ENTER
  7. If Not Etsi(Range("B1")) Is Nothing ...
  8. nyt hakee Osa1, Osa2 ja Osa3 - muuta koodissa nimet ja jos haluat etsiä kahta ehtoa niin hipsaa rivi
    If laskuri = 3 Then
    ja poista hipsu riviltä
    ' If laskuri = 3 Or laskuri = 2 Then
    muuta polku sopivaksi .LookIn = "C:\Kokeilu"

    moduuliin...

    Sub Hae()
    Dim i As Integer
    Dim wb As Workbook
    Dim laskuri As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    Range("A:A") = ""

    With Application.FileSearch
    .NewSearch
    .LookIn = "C:\Kokeilu"
    .SearchSubFolders = False
    .Filename = "*.xls"
    .Execute
    For i = 1 To .FoundFiles.Count
    laskuri = 0
    Set wb = Workbooks.Open(Filename:=.FoundFiles(i))
    If Not Etsi("Osa1") Is Nothing Then
    laskuri = laskuri + 1
    End If
    If Not Etsi("Osa2") Is Nothing Then
    laskuri = laskuri + 1
    End If
    If Not Etsi("Osa3") Is Nothing Then
    laskuri = laskuri + 1
    End If
    wb.Close
    If laskuri = 3 Then
    ' If laskuri = 3 Or laskuri = 2 Then
    Range("A65536").End(xlUp).Offset(1, 0) = .FoundFiles(i)
    End If

    Next i
    End With
    Application.ScreenUpdating = True
    End Sub


    Function Etsi(Hakuehto As Variant) As Range
    Dim solu As Range
    Dim EkaOsoite As String
    Worksheets("Taul1").Activate
    With Range("L2:L50")
    Set solu = .Find( _
    What:=Hakuehto, _
    LookIn:=xlValues, _
    LookAt:=xlWhole, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, _
    MatchCase:=False, _
    SearchFormat:=False)
    If Not solu Is Nothing Then
    Set Etsi = solu
    End If
    End With

    End Function

    Keep Excelling
    @Kunde
  9. nyt 30 argumenttiä käytössä ja nimeällä kaavan saat esim. kaava1 ja teet sitten uuden nimetyn kaavan kaava2 jne. ja sitten vaan lasket summana kaava1+ kaava2 jne.
    Nyt ei ole rajoituksista kiinni vaan koneen muistista

    matriisikaavana SHIFT+CTRL+ENTER
    =SUMMA(1*(vu1=G5)*G5;(1*(vu2=G6))*G6;(1*(vu3=G7))*G7;(1*(vu4=G8))*G8)

    VBA oma funktio
    Nimialue on solualue johon kirjoitat nimetyt solualueet. Viereisiin soluihin sitten hakuehdot ja kertoimet

    soluun mihin haluat tuloksen kaavaksi =Laskejos(C17:C100)
    eli
    solualueella C17:C100 on nimetyt alueet
    solualueella D17:D100 on hakuehdot
    solualueella E17:E100 on kertoimet

    moduuliin..

    Public Function Laskejos(Nimialue As Range) As Double
    Dim Solu As Range
    Dim i As Integer
    Dim j As Integer
    Application.Volatile True
    For i = 1 To Nimialue.Count
    For Each Solu In Range(Nimialue.Cells(i, 1))
    If Solu.Value = Nimialue.Cells(i, 1).Offset(0, 1).Value Then
    Laskejos = Laskejos + Nimialue.Cells(i, 1).Offset(0, 2).Value
    End If
    Next
    Next
    End Function
  10. helpostikin fiksattua kuten ei nörtti toteaa kopioimalla....

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Kuva As Picture
    Dim Kuva1 As Picture
    Dim Kuva2 As Picture
    Dim Kuva3 As Picture
    'jne
    On Error Resume Next
    If Not Intersect(Target, Range("C10")) Is Nothing Then
    For Each Kuva1 In Sheets("Taul1").Pictures
    If Kuva1.Top = Target.Offset(0, 1).Top And Kuva1.Left = Target.Offset(0, 1).Left Then
    Kuva.Delete
    End If
    Next Kuva1

    For Each Kuva2 In Sheets("Taul3").Pictures
    If Kuva2.Top = Target.Offset(0, 1).Top And Kuva2.Left = Target.Offset(0, 1).Left Then
    Kuva2.Delete
    End If
    Next Kuva2

    For Each Kuva3 In Sheets("Taul4").Pictures
    If Kuva3.Top = Target.Offset(0, 1).Top And Kuva3.Left = Target.Offset(0, 1).Left Then
    Kuva3.Delete
    End If
    Next Kuva3
    'jne

    With Target
    For Each Kuva In Sheets("Taul2").Pictures
    If Kuva.Name = .Text Then
    Sheets("Taul2").Shapes(Kuva.Name).Copy

    Sheets("Taul1").Activate
    ActiveSheet.Paste
    Selection.Top = .Offset(0, 1).Top
    Selection.Left = .Offset(0, 1).Left

    Sheets("Taul3").Activate
    ActiveSheet.Paste
    Selection.Top = Range("F10").Top
    Selection.Left = Range("F10").Left

    Sheets("Taul4").Activate
    ActiveSheet.Paste
    Selection.Top = Range("C4").Top
    Selection.Left = Range("C4").Left
    Exit For
    End If
    Next Kuva
    End With
    End If
    End Sub
  11. Kuvan nimeäminen:
    Klikkaa kuvaa ja nimiruudussa kirjoitat haluamasi nimen ja ENTER

    ei tartte nappia, kun nimi muuttuu niin hakee automaattisesti (jos soluun kirjoitetaan nimetty kuva löytyy kuvista)...

    toki voit tehdä kuvista listan ja laittaa sen kelpoissusehdoksi niin ainakin menee oikein( nimi on Case Sensitive) eli pitää olla just oikein kirjoitettu tai sitten koodissa muutat esim.
    If Ucase(Kuva2.Name) =Ucase( .Text) Then jolloin isoilla ja pienillä kirjaimilla ei ole eroa

    Keep Excelling
    @Kunde
  12. nyt Sheet1 solua C10 käytetään ja kuvat taulukossa Sheet2.

    taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Kuva As Picture
    Dim Kuva2 As Picture
    If Not Intersect(Target, Range("C10")) Is Nothing Then
    For Each Kuva In Sheets("Sheet1").Pictures
    If Kuva.Top = Target.Offset(0, 1).Top And Kuva.Left = Target.Offset(0, 1).Left Then
    Kuva.Delete
    End If
    Next
    With Target
    For Each Kuva2 In Sheets("Sheet2").Pictures
    If Kuva2.Name = .Text Then
    Sheets("Sheet2").Shapes(Kuva2.Name).Copy
    ActiveSheet.Paste
    Selection.Top = .Offset(0, 1).Top
    Selection.Left = .Offset(0, 1).Left
    ' Selection.Height = 200
    ' Selection.Width = 200
    Exit For
    End If
    Next Kuva2
    End With
    End If
    End Sub

    Keep Excelling
    @Kunde
  13. jos komentopainike ajaa koodin, niin kokeile laittaa sen ominaisuuksissa arvo TakeFocusOnClick =FALSE ja testaa toimiiko sitten?
    kyllä koodisi toimii ihan OK mun koneella- se vaan joskus voi olla noin, että alkaa yllättäen tökkiä koodi. Yksi syy voi olla suojattu taulukko... ja toi ekaksi mainittu kohdistus syy

    allaolevalla koodilla pitäs kyllä toimia

    Sub Lisää()
    Sheets("Sheet2").Rows("2:2").Insert Shift:=xlDown
    Sheets("Sheet1").Range("I19:K19").Copy Sheets("Sheet2").Range("A2")
    Sheets("Sheet1").Range("A1").Select
    End Sub
  14. muokkaile sopivaksi.
    Nyt toimii oikein vain jos 2 työkirjaa auki. Jos on enemmmän auki niin pitää sitten varmistaa mistä noista haetaan ja mitkä ohitetaan. No sen varmaan osaat tehdä...
    Koodissaä haetaan toisen työkirjan ekasta taulukosta soluista A20:A25 ja tallennetaan aktiivisena olevan työkirjan tokaan taulukkoon alkaen solusta A1.

    moduuliin

    Private Sub KopioToisesta()
    Dim Työkirja As Workbook
    Dim Nimi As String
    For Each Työkirja In Workbooks
    If Työkirja.Name ActiveWorkbook.Name Then
    Workbooks(Työkirja.Name).Sheets(1).Range("A20:A25").Copy ActiveWorkbook.Sheets(2).Range("A1")
    End If
    Next Työkirja
    End Sub
  15. esim.

    Sub Tyhjennä()
    Range("G1:G9,J2:J10,M6:M9") = ""
    End Sub
  16. A sarake työn vaativuustaso
    B sarake suoritustaso
    esim C1 soluun kaavaan =VLOOKUP(A1&B1;M1:N30;2;0) tai =PHAKU(A1&B1;M1:N30;2;0)


    soluissa M1:N100 palkkatiedot tyyliin

    M1=11 vaatimustaso=1 ja suoritustaso =1
    N1 =100 palkka
    M2=12 vaatimustaso=1 ja suoritustaso =2
    N2 =105 palkka
    M3=13 vaatimustaso=1 ja suoritustaso =3
    N3 =110 palkka
    M4=14 vaatimustaso=1 ja suoritustaso =4
    N4 =115 palkka
    jne...

    Keep Excelling
    @Kunde
  17. tekstikehyksessäkin tekstin kirjoittaa yhden merkin riville, jolloin se on luettavissa ylhäältä alas...
  18. tarkista sivunvaihdon asetukset valikosta VIEW/PAGE BREAK PREVIEW ja raahaa vaihdot oikealle kohdilleen...
  19. saa yksittäisen solun/rivin korkeutta isommaksi. Mutta yhdistä kaksi tai useampi solua /riviä niin sittenhän rivikorkeuskin on suurempi...
  20. hankalaa...
    huonosti osataan aina aika- ja prosenttilaskut
    edellinen oli jo lähellä, mutta kysehän oli minuuteista, eikä tunneista...

    A1=aika minuuteissa
    B1= =A1/ 1440 ja solussa muotoilu [tt]:mm:ss

    1440=24*60
    21. 42 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt