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
taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim vika As Long
On Error Resume Next
Application.EnableEvents = False
vika = Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Row
Range("A" & vika).EntireRow = ""
vika = Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Row
Range("A" & vika + 2).FormulaR1C1 = "=SUM(R[-21]C:R[-1]C)"
Range("B" & vika + 2).FormulaR1C1 = "=SUM(R[-21]C:R[-1]C)"
Range("C" & vika + 2).FormulaR1C1 = "=SUM(R[-21]C:R[-1]C)"
'näyttää 5 viimeistä tietoa, muuta lukua
Application.GoTo Range("A" & vika - 4), True
Application.EnableEvents = True
End Sub
varmaan tarkoitus on siirtää samassa työkirjassa TAULUKKOON 2,3 jne eikä TYÖKIRJAAN 2,3 jne

moduuliin...

Sub Siirrä()
Dim vika As Long
Dim solu As Range
Dim ws As Worksheet
On Error Resume Next
For Each ws In ActiveWorkbook.Worksheets
If Not ws.Name = "Sheet1" Then
ws.Range("A:B") = ""
End If
Next
Worksheets("Sheet1").Activate
vika = Range("B65336").End(xlUp).Row
For Each solu In Range(("B1:B" & vika))
Select Case UCase(solu)
Case "A"
If solu.Offset(0, 1) = 1 Then
Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet2").Range("A65336").End(xlUp).Offset(1, 0)
End If
Case "B"
If solu.Offset(0, 1) = 1 Then
Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet3").Range("A65336").End(xlUp).Offset(1, 0)
End If
Case "C"
If solu.Offset(0, 1) = 1 Then
Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet4").Range("A65336").End(xlUp).Offset(1, 0)
End If
Case "D"
If solu.Offset(0, 1) = 1 Then
Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet5").Range("A65336").End(xlUp).Offset(1, 0)
End If
Case "E"
If solu.Offset(0, 1) = 1 Then
Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet6").Range("A65336").End(xlUp).Offset(1, 0)
End If
Case "F"
If solu.Offset(0, 1) = 1 Then
Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet7").Range("A65336").End(xlUp).Offset(1, 0)
End If
Case "G"
If solu.Offset(0, 1) = 1 Then
Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet8").Range("A65336").End(xlUp).Offset(1, 0)
End If
Case "H"
If solu.Offset(0, 1) = 1 Then
Union(solu, solu.Offset(0, 7)).Copy Worksheets("Sheet9").Range("A65336").End(xlUp).Offset(1, 0)
End If
End Select
Next
End Sub
EI, EI ja EI
yleensä pyrin tekemään universaalisia koodeja, jotka toimivat pikku muutoksilla miten, missa ja milloin vaan...
niin oli kyse tälläkin kertaa...

ensin määritellään jotakin tietoa sisältävä solualue
Set Solut = Range("A:A").SpecialCells(xlCellTypeConstants)

alue saa tiedot Solut.Areas (kannattaa luke alueen määritykset ohjeesta (löytyyköhän?)- lyhyesti siis tyhjä solu solun ympärillä ):- )
joka taas saa tiedot Range("A:A").SpecialCells(xlCellTypeConstants) (kaikki tietoa sisältävät solut sarakkeesta)

For Each Alue In Solut.Areas
eli kaikki yhtenäiset alueet sarakkeessa loopataan

Vika = Range("B65336").End(xlUp).Offset(1).Row
hakee viimeisen rivin sarakkeesta B

Range("B" & Vika).Resize(, Alue.Count) = Application.Transpose(Alue)
taasen määrittelee transponoitavan "kopioaluuen" oikean kokoiseksi lähde sarakkeesta

ja lopuksi sitten poistetaan tyhjät rivit...

eli jos tarve esim sarakkeelle K...

Sub Transponoi()
Dim Vika As Long
Dim Alue As Range
Dim Solut As Range
On Error Resume Next
Rows("1:1").Insert Shift:=xlDown
Set Solut = Range("K:K").SpecialCells(xlCellTypeConstants)
For Each Alue In Solut.Areas
Vika = Range("L65336").End(xlUp).Offset(1).Row
Range("L" & Vika).Resize(, Alue.Count) = Application.Transpose(Alue)
Next Alue
Rows("1:1").Delete
Columns("K:K").Delete
End Sub

KEEP EXCELLING!
@Kunde
SAPista
villi arvaus
normaalistihan Excelissä se menee näin
1. lisää VBA puolella Tools... References viittaus ohjelmaan ( SAP) objekti kirjastoon
2. koodissa sitten jotain tämmöstä...
Set SAP = CreateObject("SAP.Application")
ja sitten tsekkaat mitä jutskia on käytetävissä vai onko mitään... );-

javascript:void(0);
ei väliä sarjojen pituudella eikä sillä miten monta tyhjää välissä
pitäisi tietenkin tyhjentää noi oikealla olevat sarakkeet ekaksi vanhoista tiedoista, mutta jääköön se kysyjän tehtäväksi
moduuliin...

Sub Transponoi()
Dim Vika As Long
Dim Alue As Range
Dim Solut As Range
On Error Resume Next
Rows("1:1").Insert Shift:=xlDown
Set Solut = Range("A:A").SpecialCells(xlCellTypeConstants)
For Each Alue In Solut.Areas
Vika = Range("B65336").End(xlUp).Offset(1).Row
Range("B" & Vika).Resize(, Alue.Count) = Application.Transpose(Alue)
Next Alue
Rows("1:1").Delete
Columns("A:A").Delete
End Sub

Keep Excelling
@Kunde
nimen voit lisätä kaavarivin vasemmalla olevaan nimiruutuun kirjoittamalla haluamasi nimen ja ENTER
If Not Etsi(Range("B1")) Is Nothing ...
nyt hakee Osa1, Osa2 ja Osa3 - muuta koodissa nimet ja jos haluat etsiä kahta ehtoa niin hipsaa rivi
If laskuri = 3 Then
ja poista hipsu riviltä
' If laskuri = 3 Or laskuri = 2 Then
muuta polku sopivaksi .LookIn = "C:\Kokeilu"

moduuliin...

Sub Hae()
Dim i As Integer
Dim wb As Workbook
Dim laskuri As Integer
On Error Resume Next
Application.ScreenUpdating = False
Range("A:A") = ""

With Application.FileSearch
.NewSearch
.LookIn = "C:\Kokeilu"
.SearchSubFolders = False
.Filename = "*.xls"
.Execute
For i = 1 To .FoundFiles.Count
laskuri = 0
Set wb = Workbooks.Open(Filename:=.FoundFiles(i))
If Not Etsi("Osa1") Is Nothing Then
laskuri = laskuri + 1
End If
If Not Etsi("Osa2") Is Nothing Then
laskuri = laskuri + 1
End If
If Not Etsi("Osa3") Is Nothing Then
laskuri = laskuri + 1
End If
wb.Close
If laskuri = 3 Then
' If laskuri = 3 Or laskuri = 2 Then
Range("A65536").End(xlUp).Offset(1, 0) = .FoundFiles(i)
End If

Next i
End With
Application.ScreenUpdating = True
End Sub


Function Etsi(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Taul1").Activate
With Range("L2:L50")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set Etsi = solu
End If
End With

End Function

Keep Excelling
@Kunde
nyt 30 argumenttiä käytössä ja nimeällä kaavan saat esim. kaava1 ja teet sitten uuden nimetyn kaavan kaava2 jne. ja sitten vaan lasket summana kaava1+ kaava2 jne.
Nyt ei ole rajoituksista kiinni vaan koneen muistista

matriisikaavana SHIFT+CTRL+ENTER
=SUMMA(1*(vu1=G5)*G5;(1*(vu2=G6))*G6;(1*(vu3=G7))*G7;(1*(vu4=G8))*G8)

VBA oma funktio
Nimialue on solualue johon kirjoitat nimetyt solualueet. Viereisiin soluihin sitten hakuehdot ja kertoimet

soluun mihin haluat tuloksen kaavaksi =Laskejos(C17:C100)
eli
solualueella C17:C100 on nimetyt alueet
solualueella D17:D100 on hakuehdot
solualueella E17:E100 on kertoimet

moduuliin..

Public Function Laskejos(Nimialue As Range) As Double
Dim Solu As Range
Dim i As Integer
Dim j As Integer
Application.Volatile True
For i = 1 To Nimialue.Count
For Each Solu In Range(Nimialue.Cells(i, 1))
If Solu.Value = Nimialue.Cells(i, 1).Offset(0, 1).Value Then
Laskejos = Laskejos + Nimialue.Cells(i, 1).Offset(0, 2).Value
End If
Next
Next
End Function
helpostikin fiksattua kuten ei nörtti toteaa kopioimalla....

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Kuva As Picture
Dim Kuva1 As Picture
Dim Kuva2 As Picture
Dim Kuva3 As Picture
'jne
On Error Resume Next
If Not Intersect(Target, Range("C10")) Is Nothing Then
For Each Kuva1 In Sheets("Taul1").Pictures
If Kuva1.Top = Target.Offset(0, 1).Top And Kuva1.Left = Target.Offset(0, 1).Left Then
Kuva.Delete
End If
Next Kuva1

For Each Kuva2 In Sheets("Taul3").Pictures
If Kuva2.Top = Target.Offset(0, 1).Top And Kuva2.Left = Target.Offset(0, 1).Left Then
Kuva2.Delete
End If
Next Kuva2

For Each Kuva3 In Sheets("Taul4").Pictures
If Kuva3.Top = Target.Offset(0, 1).Top And Kuva3.Left = Target.Offset(0, 1).Left Then
Kuva3.Delete
End If
Next Kuva3
'jne

With Target
For Each Kuva In Sheets("Taul2").Pictures
If Kuva.Name = .Text Then
Sheets("Taul2").Shapes(Kuva.Name).Copy

Sheets("Taul1").Activate
ActiveSheet.Paste
Selection.Top = .Offset(0, 1).Top
Selection.Left = .Offset(0, 1).Left

Sheets("Taul3").Activate
ActiveSheet.Paste
Selection.Top = Range("F10").Top
Selection.Left = Range("F10").Left

Sheets("Taul4").Activate
ActiveSheet.Paste
Selection.Top = Range("C4").Top
Selection.Left = Range("C4").Left
Exit For
End If
Next Kuva
End With
End If
End Sub
Kuvan nimeäminen:
Klikkaa kuvaa ja nimiruudussa kirjoitat haluamasi nimen ja ENTER

ei tartte nappia, kun nimi muuttuu niin hakee automaattisesti (jos soluun kirjoitetaan nimetty kuva löytyy kuvista)...

toki voit tehdä kuvista listan ja laittaa sen kelpoissusehdoksi niin ainakin menee oikein( nimi on Case Sensitive) eli pitää olla just oikein kirjoitettu tai sitten koodissa muutat esim.
If Ucase(Kuva2.Name) =Ucase( .Text) Then jolloin isoilla ja pienillä kirjaimilla ei ole eroa

Keep Excelling
@Kunde
nyt Sheet1 solua C10 käytetään ja kuvat taulukossa Sheet2.

taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Kuva As Picture
Dim Kuva2 As Picture
If Not Intersect(Target, Range("C10")) Is Nothing Then
For Each Kuva In Sheets("Sheet1").Pictures
If Kuva.Top = Target.Offset(0, 1).Top And Kuva.Left = Target.Offset(0, 1).Left Then
Kuva.Delete
End If
Next
With Target
For Each Kuva2 In Sheets("Sheet2").Pictures
If Kuva2.Name = .Text Then
Sheets("Sheet2").Shapes(Kuva2.Name).Copy
ActiveSheet.Paste
Selection.Top = .Offset(0, 1).Top
Selection.Left = .Offset(0, 1).Left
' Selection.Height = 200
' Selection.Width = 200
Exit For
End If
Next Kuva2
End With
End If
End Sub

Keep Excelling
@Kunde
jos komentopainike ajaa koodin, niin kokeile laittaa sen ominaisuuksissa arvo TakeFocusOnClick =FALSE ja testaa toimiiko sitten?
kyllä koodisi toimii ihan OK mun koneella- se vaan joskus voi olla noin, että alkaa yllättäen tökkiä koodi. Yksi syy voi olla suojattu taulukko... ja toi ekaksi mainittu kohdistus syy

allaolevalla koodilla pitäs kyllä toimia

Sub Lisää()
Sheets("Sheet2").Rows("2:2").Insert Shift:=xlDown
Sheets("Sheet1").Range("I19:K19").Copy Sheets("Sheet2").Range("A2")
Sheets("Sheet1").Range("A1").Select
End Sub
muokkaile sopivaksi.
Nyt toimii oikein vain jos 2 työkirjaa auki. Jos on enemmmän auki niin pitää sitten varmistaa mistä noista haetaan ja mitkä ohitetaan. No sen varmaan osaat tehdä...
Koodissaä haetaan toisen työkirjan ekasta taulukosta soluista A20:A25 ja tallennetaan aktiivisena olevan työkirjan tokaan taulukkoon alkaen solusta A1.

moduuliin

Private Sub KopioToisesta()
Dim Työkirja As Workbook
Dim Nimi As String
For Each Työkirja In Workbooks
If Työkirja.Name ActiveWorkbook.Name Then
Workbooks(Työkirja.Name).Sheets(1).Range("A20:A25").Copy ActiveWorkbook.Sheets(2).Range("A1")
End If
Next Työkirja
End Sub
esim.

Sub Tyhjennä()
Range("G1:G9,J2:J10,M6:M9") = ""
End Sub
A sarake työn vaativuustaso
B sarake suoritustaso
esim C1 soluun kaavaan =VLOOKUP(A1&B1;M1:N30;2;0) tai =PHAKU(A1&B1;M1:N30;2;0)


soluissa M1:N100 palkkatiedot tyyliin

M1=11 vaatimustaso=1 ja suoritustaso =1
N1 =100 palkka
M2=12 vaatimustaso=1 ja suoritustaso =2
N2 =105 palkka
M3=13 vaatimustaso=1 ja suoritustaso =3
N3 =110 palkka
M4=14 vaatimustaso=1 ja suoritustaso =4
N4 =115 palkka
jne...

Keep Excelling
@Kunde
tekstikehyksessäkin tekstin kirjoittaa yhden merkin riville, jolloin se on luettavissa ylhäältä alas...
tarkista sivunvaihdon asetukset valikosta VIEW/PAGE BREAK PREVIEW ja raahaa vaihdot oikealle kohdilleen...
saa yksittäisen solun/rivin korkeutta isommaksi. Mutta yhdistä kaksi tai useampi solua /riviä niin sittenhän rivikorkeuskin on suurempi...
hankalaa...
huonosti osataan aina aika- ja prosenttilaskut
edellinen oli jo lähellä, mutta kysehän oli minuuteista, eikä tunneista...

A1=aika minuuteissa
B1= =A1/ 1440 ja solussa muotoilu [tt]:mm:ss

1440=24*60
42 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt