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. LINEST (EN) tai LINREGR (FI) avulla pystyy laskemaan helpostikin ja sitten tuloksista pystyy tekeen kaavion.
    mutta solveria, kun en ole ikinä tarvinnut, niin osaa neuvoa sitä...

    Keep EXCELing
    @Kunde
  2. saa sen kolmion pois näkyvistäkin ihan asetuksilla. Kommenttiinhan voit laittaa edelliset päiväykset ja hinnat kanssa.
    Koodilla sitten taas helppo toteuttaa lähes mitä vaan ja vaikka tuo edellä mainitsemani esim. 3 vikaa hintaa ja päiväystä automaattisesti.
  3. en tarkistanut toimivuutta, mutta kaiketi pelittää ;-) ?

    pikku muutos luuppiin

    Do While Len(Tiedosto) > 0
    Set wbk = Workbooks.Open(Polku & Tiedosto)
    tw.ActiveSheet.Cells(Laskuri, 2) = wbk.Worksheets("Lokakuu").Range("C17") 'muuta solu C17 sopivaksi
    wbk.Close True
    tw.ActiveSheet.Hyperlinks.Add Anchor:=Cells(Laskuri, 1), Address:=Tiedosto, TextToDisplay:=Tiedosto
    Tiedosto = Dir
    Laskuri = Laskuri + 1
    Loop

    Keep EXCELing
    @Kunde
  4. Kommentti soluun- tai sitten koodia peliin...

    Keep EXCELing
    @Kunde
  5. Sub Summa()
    Dim Vika As Long
    Vika = Range("A65536").End(xlUp).Row
    'muuta sarake oikeaksi
    Range("A" & Vika + 1) = Application.WorksheetFunction.Sum(Range("A2:A" & Vika))
    End Sub


    Keep EXCELing
    @Kunde
  6. max 1048576 riviä taulukossa...
    joten vaatii makron, joka jakaa tiedoston useampaan taulukkoon

    Keep EXCELing
    @Kunde
  7. jos suomenkielinen versio niin korvaa Worksheet_Change makro tällä...

    Private Sub Worksheet_Change(ByVal Target As Range)
    UndoLista = Application.CommandBars("Standard").Controls("&Kumoa").List(1)
    If Left(UndoLista, 5) = "Liitä" Then
    Edellinen(0).Interior.Color = RGB(0, 255, 0)
    Application.CutCopyMode = False
    End If
    End Sub
  8. ko. taulukon moduuliin...

    Dim UndoLista As String

    Private Sub Worksheet_Activate()
    If Not Edellinen(1) Is Nothing Then
    Set Edellinen(0) = Edellinen(1)
    End If
    Set Edellinen(1) = ActiveCell
    End Sub


    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Edellinen(1) Is Nothing Then
    Set Edellinen(0) = Edellinen(1)
    End If
    Set Edellinen(1) = Target
    End Sub
    Private Sub Worksheet_Change(ByVal Target As Range)
    UndoLista = Application.CommandBars("Standard").Controls("&Undo").List(1)
    If Left(UndoLista, 5) = "Paste" Then
    Edellinen(0).Interior.Color = RGB(0, 255, 0)
    Application.CutCopyMode = False
    End If
    End Sub

    ja tavalliseen moduuliin...

    Public Edellinen(1) As Range

    Keep EXCELing
    @Kunde
  9. olikin tullut uusi korjaus jo postausten välillä...
    nyt sitten J sarakkeen solukin tyhjenee

    Private Sub Worksheet_Change(ByVal Target As Range)

    On Error Resume Next
    Application.EnableEvents = False
    If Not Intersect(Target, Range("A2:I200")) Is Nothing Then
    If Not Intersect(Target, Range("I2:I200")) Is Nothing Then
    Range("J" & Target.Row) = Now()
    Päivitä = True
    Range("L" & Target.Row) = "PÄIVITÄ"
    End If
    End If
    If Not Intersect(Target, Range("L2:L200")) Is Nothing Then
    Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)
    Range("A" & Target.Row & ":J" & Target.Row).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(1)
    Target = ""
    Range("I" & Target.Row) = ""
    Range("J" & Target.Row) = ""
    End If

    Application.EnableEvents = True
    End Sub

    Keep EXCELing

    @Kunde
  10. jäi vahingossa tohon roikkumaan turha if vertailu kun funktiona sama
    tässä korjattu versio...

    Option Explicit

    Function Uusitulos(Nykyinen, Uusi)
    If Nykyinen = "" Then
    Uusitulos = Uusi
    Else
    Uusitulos = Nykyinen & ";" & Uusi
    End If
    End Function
    Sub Lukujono(ByVal Tavoite, Luvut(), ByVal Indeksi As Integer, ByVal NykySumma, ByVal Ero As Double, ByRef Tulos(), ByVal Nykyinen As String)
    Dim i As Integer
    For i = Indeksi To UBound(Luvut)
    If Abs(NykySumma + Luvut(i) - Tavoite) <= Ero Then
    Tulos(UBound(Tulos)) = Uusitulos(Nykyinen, i + 1)
    ReDim Preserve Tulos(UBound(Tulos) + 1)
    ElseIf Indeksi < UBound(Luvut) Then
    Lukujono Tavoite, Luvut(), i + 1, NykySumma + Luvut(i), Ero, Tulos(), Uusitulos(Nykyinen, i + 1)
    End If
    Next i
    End Sub

    Sub Haeluvut()
    Dim vika As Long
    Dim i As Long
    Dim Tavoite
    Dim Tulos()
    Dim Luvut()
    Tavoite = Range("B2").Value
    Range("C2:C1000") = ""
    vika = Range("A65536").End(xlUp).Row
    Luvut = Application.WorksheetFunction.Transpose(Range("A2:A" & vika).Value)
    ReDim Tulos(0)
    i = 0
    Do Until Not Range("C3") = ""
    Lukujono Tavoite - i, Luvut, LBound(Luvut), 0, 0.00000001, Tulos, ""
    Range("A2").Offset(1, 2).Resize(UBound(Tulos) - LBound(Tulos) + 1, 1).Value = Application.WorksheetFunction.Transpose(Tulos)
    Range("A2").Offset(0, 2) = "Tavoite: " & Tavoite - i
    i = i + 1
    Loop
    End Sub
    Keep EXCELing

    @Kunde
  11. "Aivan älyttömän huippu versio alkaisi automaattisesti etsiä seuraavaa pienempää summaa."
    tossapa se sitten... ;-)

    Option Explicit

    Function Uusitulos(Nykyinen, Uusi)
    If Nykyinen = "" Then
    Uusitulos = Uusi
    Else
    Uusitulos = Nykyinen & ";" & Uusi
    End If
    End Function
    Sub Lukujono(ByVal Tavoite, Luvut(), ByVal Indeksi As Integer, ByVal NykySumma, ByVal Ero As Double, ByRef Tulos(), ByVal Nykyinen As String)
    Dim i As Integer
    For i = Indeksi To UBound(Luvut)
    If Abs(NykySumma + Luvut(i) - Tavoite) <= Ero Then
    If Nykyinen = "" Then
    Tulos(UBound(Tulos)) = i + 1
    Else
    Tulos(UBound(Tulos)) = Nykyinen & ";" & i + 1
    End If

    Tulos(UBound(Tulos)) = Uusitulos(Nykyinen, i + 1)
    ReDim Preserve Tulos(UBound(Tulos) + 1)
    ElseIf Indeksi < UBound(Luvut) Then
    Lukujono Tavoite, Luvut(), i + 1, NykySumma + Luvut(i), Ero, Tulos(), Uusitulos(Nykyinen, i + 1)
    End If
    Next i
    End Sub

    Sub Haeluvut()
    Dim vika As Long
    Dim i As Long
    Dim Tavoite
    Dim Tulos()
    Dim Luvut()
    Tavoite = Range("B2").Value
    Range("C2:C1000") = ""
    vika = Range("A65536").End(xlUp).Row
    Luvut = Application.WorksheetFunction.Transpose(Range("A2:A" & vika).Value)
    ReDim Tulos(0)
    i = 0
    Do Until Not Range("C3") = ""
    Lukujono Tavoite - i, Luvut, LBound(Luvut), 0, 0.00000001, Tulos, ""
    Range("A2").Offset(1, 2).Resize(UBound(Tulos) - LBound(Tulos) + 1, 1).Value = Application.WorksheetFunction.Transpose(Tulos)
    Range("A2").Offset(0, 2) = "Tavoite: " & Tavoite - i
    i = i + 1
    Loop
    End Sub

    Keep EXCELing
    @Kunde
  12. tavoite luku solussa B2
    tsekattavat luvut A2:AXX
    tulos C2:CXX
    nyt kaikki variaatiot tulikin samalla, jos tarttee vaan "ns". ekan niin muutellaan...

    ja suorita makro Haeluvut()

    kopioi koodi moduuliin...

    Option Explicit
    Function Uusitulos(Nykyinen, Uusi)
    If Nykyinen = "" Then
    Uusitulos = Uusi
    Else
    Uusitulos = Nykyinen & ";" & Uusi
    End If
    End Function

    Sub Lukujono(ByVal Tavoite, Luvut(), ByVal Indeksi As Integer, ByVal NykySumma, ByVal Ero As Double, ByRef Tulos(), ByVal Nykyinen As String)
    Dim i As Integer
    For i = Indeksi To UBound(Luvut)
    If Abs(NykySumma + Luvut(i) - Tavoite) <= Ero Then
    If Nykyinen = "" Then
    Tulos(UBound(Tulos)) = i + 1
    Else
    Tulos(UBound(Tulos)) = Nykyinen & ";" & i + 1
    End If

    Tulos(UBound(Tulos)) = Uusitulos(Nykyinen, i + 1)
    ReDim Preserve Tulos(UBound(Tulos) + 1)
    ElseIf Indeksi < UBound(Luvut) Then
    Lukujono Tavoite, Luvut(), i + 1, NykySumma + Luvut(i), Ero, Tulos(), Uusitulos(Nykyinen, i + 1)
    End If
    Next i
    End Sub

    Sub Haeluvut()
    Dim vika As Long
    Dim i As Long
    Dim Tavoite
    Dim Tulos()
    Dim Luvut()
    Tavoite = Range("B2").Value
    Range("C2:C1000") = ""
    vika = Range("A65536").End(xlUp).Row
    Luvut = Application.WorksheetFunction.Transpose(Range("A2:A" & vika).Value)
    ReDim Tulos(0)
    Lukujono Tavoite, Luvut, LBound(Luvut), 0, 0.00000001, Tulos, ""
    Range("A2").Offset(0, 2).Resize(UBound(Tulos) - LBound(Tulos) + 1, 1).Value = Application.WorksheetFunction.Transpose(Tulos)
    End Sub

    Keep EXCELing
    @Kunde
  13. Klikkaa haluamasi taulukon valitsinta tilarivillä hiiren oikealla. Aukeavasta valikosta sitten valitse Näytä koodi ja kopioi oikealla olevaan valkeaan tilaan koodisi.
    Tallenna.
    Aina kun muutat taulukossa A13 arvoa koodi toimii...

    Keep EXCELing
    @Kunde
  14. Ei siihen makroa tartte....
    jos haluat, että toimii Taul1, niin kopioi allealeva Taul1 moduulin ja se on siinä...
    aina kun A13 muuttuu, suorittaa automaattisesti makron.

    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo virhe
    Application.EnableEvents = False
    If Not Intersect(Target, Range("A13")) Is Nothing Then
    Range("A1").Copy Range("C65536").End(xlUp).Offset(1, 0)
    Range("A2:A13").Copy Range("A1")
    Range("A13") = ""
    End If
    virhe:
    Application.EnableEvents = True
    End Sub

    "object required" virhe tulee siitä, kun sulla ei ole määritelty Dim Target As Range ...

    KEEP EXCELing

    @Kunde
  15. soluun MATRIISIKAAVA
    {=MAKS(JOS(A1:A1000
    muuta solualue sopivaksi...

    Keep EXCELing
    Kunde
  16. Sub LisääKuvaKommenttiin()

    Dim solu As Range
    On Error Resume Next

    For Each solu In Range("B3:AB12,B15:AB24,B27:AB36")
    If Not solu = "" Then
    If Not solu.Comment Is Nothing Then solu.Comment.Delete
    With solu
    .AddComment
    .Comment.Visible = False
    .Comment.Shape.Fill.UserPicture ThisWorkbook.Path & "\" & solu & ".jpg"
    .Comment.Shape.Height = 300
    .Comment.Shape.Width = 250
    End With
    Next
    End If
    End Sub

    Keep EXCELing
    @Kunde
  17. tota varten on olemassa Datalomake...
    jos lontoo taipuu niin tsekkaa...
    http://spreadsheets.about.com/od/datamanagementinexcel/ss/090717_data_form.htm

    Keep EXCELing
    @Kunde
  18. ilmeisesti sulla on jo jo toi Worksheet_SelectionChange tapahtuma koodi siellä... joten lisää sitten toi koodi sinne ilman ekaa ja vikaa riviä
    eli ilman näitä rivejä
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    End Sub
    Zoom100 = 100
    Zoom150 = 150
    100 on normaali ja zoom150 =150 on nyt zoomaus 150% ja jos muutat
    Zoom100 = 100
    Zoom150 = 200 niin zoomaus 200%...

    Keep EXCELing
    @Kunde
  19. ko. taulukon moduuliin...
    toimii kaikilla soluilla, jossa kelpoisuustarkistus listalla....
    muuta zoomiluvut sopiviksi

    kuten olen aiemmin postannut, toimii kaikissa soluissa, missä kelpoisuustarkistus lista...
    nyt zoomaa 150%, muuta Zoom150 arvoa isommaksi, jos tarttet isompaa zoomausta

    ei muuta kuin ALT+F11 ja tuplaklikkaa vasemmalla ko.taulukon nimeä ja liität koodin ko. taulukon moduuliin oikealle tyhjään tilaan ja se on siinä

    Keep EXCELing
    @Kunde
  20. ko. taulukon moduuliin...
    toimii kaikilla soluilla, jossa kelpoisuustarkistus listalla....
    muuta zoomiluvut sopiviksi

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Zoom100 As Long
    Dim Zoom150 As Long
    Dim Datatyyppi As Long
    Zoom100 = 100
    Zoom150 = 150
    Application.EnableEvents = False
    On Error Resume Next
    Datatyyppi = Target.Validation.Type
    On Error GoTo Virhe
    If Datatyyppi = 3 Then

    If ActiveWindow.Zoom Zoom150 Then
    ActiveWindow.Zoom = Zoom150
    End If
    Else

    If ActiveWindow.Zoom Zoom100 Then
    ActiveWindow.Zoom = Zoom100
    End If
    End If

    Poistu:
    Application.EnableEvents = True
    Exit Sub
    Virhe:
    GoTo Poistu
    End Sub

    Keep EXCELing
    @Kunde
    21. 14 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt