kunde
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 sitten
Muokkaa profiilia7 aloitusta · 1377 kommenttia
- 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 kunde@hotmail.fi
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