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
eihäm tommosta ookaan joka osaa lukea sun ajatukset ja laittaa ne sarakkeeseen...
jos haluat niin makrolla voi tehdä aktiivisesta solusta alkaen (oletuksena nyt sitten alaspäin...) antamastasi päiväyksestä alkaen loppupäiväykseen kuukausittain päiväykset ja muuttaa ne muotoon elokuu 11, syyskuu 11
tommostako haluat....
tiedot pitää olla 2 eri sarakkeessa, koska tekstilajittelu hankalampaa numeroill eli esim Csarake pvm ja D -sarake asiakas
oletuksena tiedot alkaa C1
jos tiedot alkaa muualta muuta osoitteita

toimii nyt näin
syötetään tieto C-sarakkeeseen ja jos D sarakkeesta puuttuu vastaava tieto siirtyy siihen. Jos D sarakkeessa oli tieto lajittelee
ja päinvastoin D sarakkeen kanssa

taulukon moduuliin...

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("C:D")) Is Nothing Then
If Not Intersect(Target, Columns("C:C")) Is Nothing Then
If Target.Offset(0, 1) = "" Then
Target.Offset(0, 1).Select
GoTo loppu
End If
Else
If Target.Offset(0, -1) = "" Then
Target.Offset(0, -1).Select
GoTo loppu
End If
End If
Columns("C:D").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If
loppu:
End Sub

Keep EXCELing
@Kunde
niksinurkasta toka postaus

http://keskustelu.suomi24.fi/node/9847941
jos olet valinnut hiirellä solualueen ja vapautat hiiren ja toteat, että alue on joko liian suuri tai pieni ja haluat muuttaa sen kokoa niin SHIFT pohjassa klikkaa hiirellä uusi toisen suorakulman nurkkasolu
TAI
näppäimellä F8 ja tilariville ilmestyy EXT valinta voit sitten muuttaa valinnan kokoa ja uudelleen painamalla poistut laajemmustilasta
tavalliseen moduuliin VBA editorin puolella...

palkka on 0€ - en oo töissä enkä eläkkeellä kunhan vaan vetelen lonkkaa tällähetkellä.
Toki ohjelmointikeikkoja voin ottaa vastaan (kokemustahan mulla taitaa olla piisalle asti...)
moduuliin...

Option Explicit

Function Pvmluvuksi(Solu As Range) As Double
Pvmluvuksi = CDbl(Day(Solu) & Month(Solu) & Format(Solu, "yy"))
End Function

Sub koe()
ActiveCell = Pvmluvuksi(ActiveCell)
ActiveCell.NumberFormat = "General"
End Sub

2 tapaa käyttää , joko

1. Aktivoi solu ja suorita makro Koe (tee nappi makrolle)

2. Solu mihin haluat tuloksen kirjoita kaava esim arvo solusta C1 =Pvmluvuksi(C1)

jos luvut esim tietyssä sarakkeessa, niin silloin voisi tehdä aluemakron ja ei tartteisi yksitellen napsutella


Keep EXCELing
@Kunde
ฉันจะให้การฝึกอบรม EXCEL, แต่ฉันไม่ให้การศึกษาขั้นพื้นฐาน

Keep EXCELing
@Kunde
moduuliin...

Option Explicit
Sub Järjestä()
Dim vika As Long
Dim i As Long
vika = Range("A65536").End(xlUp).Row
For i = vika To 2 Step -2
Range("A" & i - 1) = Range("A" & i - 1) & " " & Range("A" & i)
Range("A" & i).Delete
Next
End Sub


Keep EXCELing
@Kunde
miksi kysyt uudelleen samaa kun toimivat vastauksetkin jo alet saanut...

http://keskustelu.suomi24.fi/node/9888741
=PROPER(RIGHT(A1;(LEN(A1)-(FIND(" ";A1))))&" "&LEFT(A1;(FIND(" ";A1)-1)))
EI
taulukon moduuliin...

Option Explicit

Private Sub Worksheet_Change(ByVal target As Range)
Dim solu As Variant
On Error Resume Next
Application.EnableEvents = False
solu = target

If Not Intersect(target, Range("B1:E1")) Is Nothing Then
Range("B1:E1") = ""
Range("A1") = solu
target = solu
End If
Application.EnableEvents = True
End Sub

Keep EXCELing
Keep ARCHAing
@Kunde
ei päätä eikä häntää selityksessä...
mallihan oli selkeä...
transponoi koko taulukon

moduuliin...

Option Explicit

Sub Transponoi()
Dim i As Long
Dim vikarivi As Long
Dim vikasarake As Long
On Error Resume Next
Application.ScreenUpdating = False
vikarivi = Range("A65536").End(xlUp).Row
vikasarake = Range("A1").End(xlToRight).Column
For i = 1 To vikarivi
Range("A" & i, Range("A" & i).Offset(0, vikasarake - 1)).Copy
Range("A" & vikarivi + 1).Offset(0, i - 1).PasteSpecial xlValues, Transpose:=True
Next i
Rows("1:" & vikarivi).Delete
Application.CutCopyMode = False
Range("A1").Activate
Application.ScreenUpdating = True
End Sub

Keep EXCELing
@Kunde
laita mulle email [email protected]

alku ja lopputilanne eri taulukoihinsa
moduuliin...

Option Explicit
Dim Alue As Range
Dim a As Variant
Sub Transponoi()
Range("A8").Cut Range("H1")
Set Alue = Range(Range("B8"), Range("B8").End(xlToRight))
a = Range(Range("B8"), Range("B8").End(xlToRight)).Value
Alue = ""
Range("H2", Range("H2").Offset(Alue.Count - 1, 0)) = ""
Range("H2:H" & Alue.Count + 1) = Application.WorksheetFunction.Transpose(a)
Application.CutCopyMode = False
End Sub
Sub Transponoi2()
Range("H1").Cut Range("A8")
Set Alue = Range(Range("H2"), Range("H2").End(xlDown))
a = Range(Range("H2"), Range("H2").End(xlDown)).Value
Range("B8", Range("B8").Offset(0, Alue.Count - 1)) = ""
Alue = ""
Range("B8", Range("B8").Offset(0, Alue.Count - 1)) = Application.WorksheetFunction.Transpose(a)
Application.CutCopyMode = False
End Sub

Keep EXCELing
@Kunde
jälkimmäistä kyssäriä en ymmärtänyt?

muuta alue sopivaksi
moduuliin...

Option Explicit

Sub PoistaTyhjätRivit()
Dim Alue As Range
Dim Rivi As Long
Dim Sarake1 As Long
Dim Sarake2 As Long
On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Alue = Range("B8:M40")
Sarake1 = Alue(1, 1).Column
Sarake2 = Alue(1, 1).Offset(0, Alue.Columns.Count - 1).Column
For Rivi = Alue(Alue.Count).Row To Alue.Cells(1, 1).Row Step -1
If ALueTyhjä(Range(Cells(Rivi, Sarake1), Cells(Rivi, Sarake2))) Then
Range("A" & Rivi).EntireRow.Hidden = True
End If
Next Rivi
virhe:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Function ALueTyhjä(Alue As Range) As Boolean
ALueTyhjä = (WorksheetFunction.CountA(Alue) = 0)
End Function
Sub resetoi()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Keep EXCELing
@Kunde
eipä näy kuvassa kuin taulukonvalitsin, joten vaikeata arvuutella...
no korjattu nyt, mutta tekstistä en oo varma kun ei oo tietoa miten se on tiedostossa...
mutta eipähän toi laske kuin lukuja nyt sitteen...
Option Explicit
Sub Keskiarvo()
Dim Originaali As Range
Dim vika As Long
Dim i As Long
Dim lkm As Long
Dim solu As Range
On Error Resume Next

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set Originaali = Columns("A:B")
Worksheets("Uusi").Delete
On Error GoTo 0
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Uusi"
Originaali.Copy Range("A1")
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Rows("1:2").Insert
vika = Range("A65536").End(xlUp).Row
lkm = 1
For i = vika To 3 Step -1
If Format(Range("A" & i), "hh") = Format(Range("A" & i - 1), "hh") Then
Range("A" & i).Offset(-1, 1) = Range("A" & i).Offset(-1, 1) + Range("A" & i).Offset(0, 1)
Range("A" & i).Offset(-1, 2) = Range("A" & i - 1).Offset(-1, 2) + lkm + 1
lkm = lkm + 1
Range("A" & i).EntireRow.Delete
Else
If lkm = 1 Then
Range("A" & i).Offset(-1, 1) = Range("A" & i).Offset(-1, 1) + Range("A" & i).Offset(0, 1)
Range("A" & i).Offset(0, 2) = 1
End If
lkm = 1
End If
Next
vika = Range("B65536").End(xlUp).Row
For Each solu In Range("B3:B" & vika)
If IsNumeric(solu) Then
solu = solu / solu.Offset(0, 1)
End If
Next
Range("A:A").NumberFormat = "dd/yy/mm hh"
Range("B:B").NumberFormat = "0.00"
Range("C:C").Delete
Range("B2") = "Keskiarvo"
ActiveCell.Columns("A:B").EntireColumn.EntireColumn.AutoFit

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Keep EXCELing
@Kunde
VBA:lla
nyt tarkistaa solua C1 lisää soluja tarvittaessa

taulukon moduuliin...

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("D1")) Is Nothing Then
If InStr(1, Target, ".") > 0 Then
Target = ""
MsgBox "pistettä ei hyväkstytä desimaalierottimena!"
Target.Select
GoTo loppu
Exit Sub
End If
If Target = "" Then
Target = ""
Else
If InStr(1, Target, ",") > 0 Then
Target = Format(Target, "0.00") & " kN/m²"
Else
Target = Format(Target, "0") & " kN/m²"
End If
End If
End If
loppu:
Application.EnableEvents = True
End Sub
Keep EXCELing
@Kunde
29 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt