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
mokahan siinä on...
oli väärässä paikkaa toi "näytä kaikki" koodirivi

Private Sub Worksheet_Change(ByVal Target As Range)
Dim vika As Integer
Dim solu As Range

On Error Resume Next
vika = Range("C65336").End(xlUp).Row
Application.EnableEvents = False

If Not Intersect(Target, Range("C13")) Is Nothing Then
ActiveSheet.ShowAllData
If Target = "" Then
Range("G13") = ""
GoTo poistu
End If
Range("C13:G" & vika).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
For Each solu In Range("C14:C" & vika).SpecialCells(xlCellTypeVisible)
If Not solu = Range("C13") Then
solu.EntireRow.Hidden = True
End If
Next solu
Range("G13") = ""
End If
If Not Intersect(Target, Range("G13")) Is Nothing Then
ActiveSheet.ShowAllData
If Target = "" Then
Range("C13") = ""
GoTo poistu
End If
Range("C13:G" & vika).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
For Each solu In Range("G14:G" & vika).SpecialCells(xlCellTypeVisible)
If Not solu = Range("G13") Then
solu.EntireRow.Hidden = True
End If
Next solu
Range("C13") = ""
End If
poistu:
Application.EnableEvents = True
End Sub
kokeiles koodissa seuraavaa
klikkaa hiiren vaemmalla rivien välissä
Private Sub Worksheet_Change(ByVal Target As Range)
...
End Sub

sitten klikkailet F8 ja tutkaile koodissa seuraavaa riviä. (Voi tän tehdä fiksumminkin , mutta hankala selittää...)
Vie hiiri solu sanan päälle ja tsekkaa sen arvo samoin tee Range("C13") sanalle. Vertaile näytettyjä arvoja ja tutki mikä ero niillä on? Ettei vaan olisi ylimääräisiä merkkejä soluissa? Jos näin on niin sitten koodin trimmikomentoa tai pituuden tarkistusta yms...

If Not solu = Range("C13") Then
sillä voit suodattaa niitä lukuja C sarakkeessa samanlailla kuin kuukausilla G sarakkeessa- et sitä sitten näköjään tarvinnut... ;-)

kiitos palautteesta!

Keep Excelling
@Kunde
kuten kirjoitin
1. Poista suodatus taulukosta
2. Liitä koodi TAULUKON MODUULIIN
3 .kirjoita soluihin C13 tai G13 hakuehtosi ja uniikit näkyy...
kelpoisuusehto dsoluun G13 helpottaa kuukausien suodatusta... ja
C13 sitten vaatii sen combon ja koodin..
tarkista värien koodinumerot , jotta ovat oikeita. Nauhoita vaikka makro ja vaihda fontinväriä ja tarkista fontinvärikoodi numerot...

soluun kaavaesim. =SummaVärillä(I1:I60)

moduuliin...

Function SummaVärillä(Alue As Range) As Double
Dim solu As Range
Application.Volatile True
For Each solu In Alue
If solu.Font.ColorIndex = 3 Or solu.Font.ColorIndex = 10 Then
SummaVärillä = SummaVärillä + solu
End If
Next solu
End Function

Keep Excelling
@Kunde
Autofilter pois käytöstä...

nyt kun solut C13 tai G13 muuttuu niin suodattaa uniikit solun mukaan. Jos solu tyhjä niin näyttää kaikki.
Suodatussoluihinhan voisi tietenkin lisätä combon ja sen arvoiksi uniikit sarakkeesta ja näin ollen toimisi kuten suodatusnappikin...
no siinä purtavaa sulle- varmasti palstalta löytyy mun koodinpätkä siihenkin, joten hakua peliin...
G13 solussa voit käyttää vaikka KELPOISUUSEHTOA listan lähteeksi tammi;helmi;maalis jne.

taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim vika As Integer
Dim solu As Range

On Error Resume Next
ActiveSheet.ShowAllData
vika = Range("C65336").End(xlUp).Row
Application.EnableEvents = False

If Not Intersect(Target, Range("C13")) Is Nothing Then
If Target = "" Then
Range("G13") = ""
GoTo poistu
End If
Range("C13:G" & vika).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
For Each solu In Range("C14:C" & vika).SpecialCells(xlCellTypeVisible)
If Not solu = Range("C13") Then
solu.EntireRow.Hidden = True
End If
Next solu
Range("G13") = ""
End If
If Not Intersect(Target, Range("G13")) Is Nothing Then
If Target = "" Then
Range("C13") = ""
GoTo poistu
End If
Range("C13:G" & vika).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
For Each solu In Range("G14:G" & vika).SpecialCells(xlCellTypeVisible)
If Not solu = Range("G13") Then
solu.EntireRow.Hidden = True
End If
Next solu
Range("C13") = ""
End If
poistu:
Application.EnableEvents = True
End Sub

' jos sattuu moka, niin toimintojen palautuskoodi alla

Sub Resetoi()
On Error Resume Next
Application.EnableEvents = True
ActiveSheet.ShowAllData
End Sub
ei voi käyttää suodatusta.
Mutta kikkaillahan aina voi...

Keep Excelling
@Kunde
moduuliin...

Sub PiilotaTuplat()
Dim vika As Integer
vika = Range("C65336").End(xlUp).Row
Range("C1:G" & vika).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End Sub

Sub NäytäKaikki()
ActiveSheet.ShowAllData
End Sub

Keep Excelling
@Kunde
jos tota käytät, ei toimi, koska Alue määritelty väärin...
mutta
siis haluat, että B sarakkeessa tehdään haku kuukausilla(arvaus ;-)) ja näytetään uniikit?
voiko tuloksen näyttää muualla kuin originaalipaikassa?
käykö lomake?

kerro lisää...

Keep Excelling
@Kunde
n. 10 vuotta sain kivasti TEKES:ltä rahaa koodin pätkästäni...
Ajat muuttuneet ja nyt muutamalla kympillä näkyy olevan tarjolla ohjelmia.
Sahojen/leikkureiden mukanahan tulee yleensä omat ohjelmat.
Kandee siis googlettaa ja ladata ilmaisia demoja ja valita itselleen sopivassa budjektissa oleva ohjelma. Halvimman ja kalleimman ohjelman välinen optimointitulos voi olla isokin, mutta luulisin tommosella 100-200 USD saavan jo kelpo softan. Turha uhrata tuhansia.
Ja jos optimointi ei ole hyvä niin lisää jotain bulkkituotetta(jos semmosia on tuotannossa) täytteeksi nestaukseen ja tulos paranee huomattavasti yleensä (ilmainen vinkki!) - niin sitä tehdään kalliimmillakin CAD/CAM ohjelmilla
minkähänlainen se sun makros mahtaa olla, mitä pitäs muuttaa???
tottahan voin tehdä omankin version, mutta mielenkiinnosta haluan nähdä sinunkin version....
olinpas lukenut huolimattomasti kyssärin...
kopioi oikealle
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
Select Case Target
Case 27
Target.Offset(0, 1) = 24
Case 35
Target.Offset(0, 1) = 30
Case 66
Target.Offset(0, 1) = 60
'JNE..
Case Else
Target.Offset(0, 1) = Target
End Select
End If
End Sub

ja alaspäin...

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
Select Case Target
Case 27
Target.Offset(1, 0) = 24
Case 35
Target.Offset(1, 0) = 30
Case 66
Target.Offset(1, 0) = 60
'JNE..
Case Else
Target.Offset(1, 0) = Target
End Select
End If
End Sub
taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
Select Case Target
Case 27
Target = 24
Case 35
Target = 30
Case 66
Target = 60
'JNE..
Case Else
End Select
End If
End Sub
Illustrator export ja .PNG muto. Näyttäis aika hyvältä...
Function EtsiJaSiirrä2(Hakuehto As Variant) As Range

Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
With Range("G:G")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set EtsiJaSiirrä2 = solu
EkaOsoite = solu.Address
Do
Set EtsiJaSiirrä2 = Union(EtsiJaSiirrä2, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address EkaOsoite
End If
End With
End Function

Sub Testi2()
Dim Löydetty As Range
Dim solu As Range
On Error GoTo virhe
Set Löydetty = EtsiJaSiirrä2("Nok")
For Each solu In Löydetty
Union(solu.Offset(0, -6), solu.Offset(0, -5), solu.Offset(0, -4)).Copy Range("Sheet2!A65536").End(xlUp).Offset(1, 0)
Next
Exit Sub
virhe:
MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
End Sub
"ei tietoa, liittynee jotenkin duplikaatteihin...."
varmaankinliittyy tupliin- 555 hahaha ;-)

moduuliin...

muuta sarake oikeaksi nyt A-sarake
eka koodinpätkä piilottaa tuplat ja toka palauttaa kaikki...

Sub PiilotaTuplaRivit()
Dim vika As Long
Dim i As Long
vika = Range("A65536").End(xlUp).Row
For i = vika To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("A1:A" & i), Range("A" & i)) > 1 Then
Range("A" & i).EntireRow.Hidden = True
End If
Next i

End Sub
Sub NäytäKaikki()
Rows.Hidden = False
End Sub
palauttaa // välissä olevan luvun
=MID(E7;FIND("/";E7;1)+1;FIND("/";E7;FIND("/";E7;1)+1)-FIND("/";E7;1)-1)
=LEFT(REPLACE(E7;1;F7;"");FIND("/";REPLACE(E7;1;F7;"");1)-1)

koodaamalla tietenkin ja kuten tuttumies mainitsi teksti sarakkeisiin
hakusanoja etsijasiirrä haejasiirrä
kirjoittaja kunde ja kymmeniä esimerkkejä ja melkeimpä suoran toimiva koodi
Keep Excelling
@Kunde
soluun mihin haluat tuloksen esim. solusta C2 =Erottele(C2)

ja moduuliin...
(virhetarkastelu puuttuu kun ei tarkempaa selostusta tarpeista) antaa nyt virheilmoituksen kun solu on tyhjä tai sarjassa ei ole numeroa alussa.

Function Erottele(txt As String) As Variant
If IsNumeric(txt) Then
Erottele = Val(txt)
Exit Function
End If
With CreateObject("VBScript.RegExp")
.Pattern = "-?\d+"
Erottele = .Execute(txt)(0)
Erottele = Erottele & " " & Mid(Range("C2"), Len(Erottele) + 1)
End With
End Function
oikeasti vaikka näin...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim vika As Long
Dim kaava As String
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
kaava = "A1:A" & vika
Range("A" & vika + 2).Formula = "=SUM(" & kaava & ")"
kaava = "B1:B" & vika
Range("B" & vika + 2).Formula = "=COUNTA(" & kaava & ")"
kaava = "C1:C" & vika
Range("C" & vika + 2).Formula = "=AVERAGE(" & kaava & ")"
'näyttää 5 viimeistä tietoa, muuta lukua
Application.GoTo Range("A" & vika - 4), True
Application.EnableEvents = True
End Sub
41 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt