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. Ilmeisesti sulla oli saman taulukon koodissa 2 saman nimistä proseduuria?
  2. Piece of cake
    arvatenkin haluat sieltä Taul2 jostain solusta lisätä johonkin Taul1 soluun hakemasia tietoja. Entä jos on jo tietoa solun kommentissa - poistetaanko vaiko lisätään perään?


    Keep EXCELing
    @Kunde
  3. Mitähän sääntöjen vastaista mun vastauksessa mahtoi olla???
  4. 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
  5. 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.
  6. 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
  7. Kommentti soluun- tai sitten koodia peliin...

    Keep EXCELing
    @Kunde
  8. 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
  9. max 1048576 riviä taulukossa...
    joten vaatii makron, joka jakaa tiedoston useampaan taulukkoon

    Keep EXCELing
    @Kunde
  10. 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
  11. 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
  12. 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
  13. 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
  14. "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
  15. 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
  16. 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
  17. 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
  18. soluun MATRIISIKAAVA
    {=MAKS(JOS(A1:A1000
    muuta solualue sopivaksi...

    Keep EXCELing
    Kunde
  19. 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
  20. tota varten on olemassa Datalomake...
    jos lontoo taipuu niin tsekkaa...
    http://spreadsheets.about.com/od/datamanagementinexcel/ss/090717_data_form.htm

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