kunde

kunde profiilikuva
Joulu 2024
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

Liittynyt 20v sitten
7 aloitusta · 1377 kommenttia
Uusimmat aloituksetSuosituimmat aloituksetUusimmat kommentit
Ilmeisesti sulla oli saman taulukon koodissa 2 saman nimistä proseduuria?
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
Mitähän sääntöjen vastaista mun vastauksessa mahtoi olla???
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
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.
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
Kommentti soluun- tai sitten koodia peliin...

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

Keep EXCELing
@Kunde
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
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
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
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
"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
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
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
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
soluun MATRIISIKAAVA
{=MAKS(JOS(A1:A1000
muuta solualue sopivaksi...

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

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