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
... koodia
MsgBox Application.WorksheetFunction.CountA(Range("B12:B61"))
End Sub
jos taulukossa on omat otsikkorivit (ei pelkät kirjaimet A,B,C...) ylhäällä tai alhaalla ja omat riviotsikot ( ei pelkät mumerot 1,2,3...) vasemmalla tai oikealla niin kaikkein helpoin tapa on käyttää Excelin omaa NATIVE LANGUAGEta

Eli valikosta LISÄÄ/ NIMI/ LUO ja avautuvasta lomakkeesta valitset sopivat vaihtoehdot taulukon luomiseen .
Sitten soluun mihin haluat tuloksen teet kaavan = RIVIOTSIKKO (VÄLILYÖNTI )SARAKEOTSIKKO

eli jos myyntitaulukossa sarakkeina esim tammi,helmi,maalis... ja riviotsikkoina esi. Pohjoinen, Etelä, Itä, Länsi

ja haluat saada selville helmikuun Etelän myynnin niin soluun kaava =helmikuu Etelä tai =Etelä helmikuu
Ruokahalu kasvaa syödessä näköjään...
nyt ei väliä montako samaa aluetta löytyy...

Function Etsi(Hakuehto As Variant) As Range
'etsii Sheet1 sarakkeesta A ja siirtää Sheet2 sarakkeeseen O
'oletuksena, että haettavat tiedot vain sarakkeessa A
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Taul1").Activate
With Range("A:A")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set Etsi = solu
EkaOsoite = solu.Address
Do
Set Etsi = Union(Etsi, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address EkaOsoite
End If
End With
End Function

Sub HakuEhdoilla()
On Error Resume Next
Dim Löydetty As Range
Dim Löydetty2 As Range
Dim solu As Range
Dim vika As Long
Set Löydetty = Etsi(Chr(126) & Range("E1"))
Set Löydetty2 = Etsi(Chr(126) & Range("E2"))
If Löydetty.Areas.Count = Löydetty2.Areas.Count Then
For i = 1 To Löydetty.Areas.Count
Range(Löydetty.Areas(i).Cells(1, 1).Offset(1, 0).Address & ":" & Löydetty2.Areas(i).Cells(1, 1).Address).Copy Worksheets("Taul2").Range("A65536").End(xlUp).Offset(1, 0)
vika = Worksheets("Taul2").Range("A65536").End(xlUp).Row
Worksheets("Taul2").Range("A" & vika) = Left(Worksheets("Taul2").Range("A" & vika), InStr(1, Worksheets("Taul2").Range("A" & vika), "~", 1) - 1)
Next
Else
MsgBox "Ristiriita alueiden kanssa"
End If
End Sub

Keep EXCELing
@Kunde
muotoile sopivaksi ...
esim. nyt

hakee Taul1 A -sarakkeesta solunjen E1 ja E2 väliset luvut TAul2 A-sarakkeeseen...

aloitusehto solussa E1
lopetusehto solussa E2

Sub HakuEhdoilla()
On Error Resume Next
Dim Löydetty As Range
Dim Löydetty2 As Range
Dim solu As Range
Dim vika As Long
Set Löydetty = Etsi(Chr(126) & Range("E1"))
Set Löydetty2 = Etsi(Chr(126) & Range("E2"))
Range(Löydetty.Offset(1, 0).Address & ":" & Löydetty2.Address).Copy Worksheets("Taul2").Range("A65536").End(xlUp).Offset(1, 0)
vika = Worksheets("Taul2").Range("A65536").End(xlUp).Row
Worksheets("Taul2").Range("A" & vika) = Left(Worksheets("Taul2").Range("A" & vika), InStr(1, Worksheets("Taul2").Range("A" & vika), "~", 1) - 1)
End Sub

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

Keep EXCELing
@Kunde
Viile Virtanen tyyliset ihan OK

ongelmia, nimissähän voi olla väliviiva tai sitten ei ...
Anna Kaisa Virtanen
Anna-Kaisa Virtanen
Anna Kaisa Virtanen Lahtinen
Anna-Kaisa Virtanen Lahtinen
Anna-Kaisa Virtanen-Lahtinen

asiaa puitu aiemmin ainakin näissä ketjuissa, ja melkein toimivia ratkaisujakin löydetty...

http://keskustelu.suomi24.fi/node/1645628#comment-8028249
http://keskustelu.suomi24.fi/node/1466093#comment-7097195

Keep EXCELing
@Kunde
Ei siihen mitään loppusummia pidä lisätä, se laskee ne automaattisesti...
testasin tosin sen vain aloittamalla tyhjällä sarakkeella ja lisäämällä uuden rivin/rivejä ja ainakin oletukseni toimii niinkuin halusit....
siis ei mitään omia kaavoja

Keep EXCELing
@Kunde
painovirhepaholainen ;-)
oikea koodi

Dim vika As Long
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
Range("H:H, L:L, M:M").SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = xlNone
vika = Range("F65536").End(xlUp).Row
If vika = 1 Then
Range("F" & vika + 1) = Application.WorksheetFunction.Sum(Range("F1:F1"))
Else
Range("F" & vika) = Application.WorksheetFunction.Sum(Range("F1:F" & vika - 1))
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub reset()
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function kaavantulos(r As Range)
f = r.Formula
v = r.Value
If (InStr(f, "=") = 1) Then
kaavantulos = v
Else
kaavantulos = ""
End If
End Function

turhaa testailua kun excelissä valmis funktio...

sama

Function kaavantulos2(r As Range)
If r.HasFormula Then
kaavantulos2 = r.Value
Else
kaavantulos2 = ""
End If
End Function

Keep EXCELing
@Kunde
kopioi kaavasolut aktiivisesta taulukosta taulukko2 samoihin soluihin...

Sub b()
For Each solu In Cells.SpecialCells(xlCellTypeFormulas)
solu.Copy
Worksheets("Taul2").Range(solu.Address).PasteSpecial xlPasteValues
Next
Application.CutCopyMode = False
End Sub


Keep EXELing
@Kunde
Taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
Range("H:H, L:L, M:M").SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = xlNone
vika = Range("F65536").End(xlUp).Row
If vika = 1 Then
Range("F" & vika + 1) = Application.WorksheetFunction.Sum(Range("F1:F1"))
Else
Range("F" & vika) = Application.WorksheetFunction.Sum(Range("F1:F" & vika - 1))
End If
Range("F" & vika) = Application.WorksheetFunction.Sum(Range("F1:F" & vika - 1))
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub reset()
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub


Keep EXCELing
@Kunde
taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
Range("H:H, L:L, M:M").SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = xlNone
End Sub

toinen kyssäri:
missä loppusumma?
"Eli saako tuota automaattista solujen värjäytymistä jotenkin pois? Eli jos esim. solu H29 on vihreä, tulee sen alapuolella olevastakin H30 solusta vihreä mikäli lisään rivejä"

Joopa joo
ihan eri juttu...
no katellaan kun keritään
hehehe...
ehkäpä Kundepuu (alias Kunde auttaa sua kaupallisesti -maybe too heavy to free)...
kymmeniä mun tekemiä vastaavia koodin pätkiä löytyy haulla (ainut ero , että useimmat palauttaa koko rivin, mutta pikku rukkauksella palauttaa mitä tahansa ja mistä kohtaa tahansa... ;-)
laita se suurimmalla numerolla oleva referenssi käyttöön.
Joku referenssi siiinä koneessa on muuttunut. Jos referenssi puuttuu niin se herjaa puuttumista. Ehkäåä se koodi olisi parasta olla normaalimoduulissa eikä This Workbook moduulissa?
TArgettia voit käyttää vain taulukon tapahtumakoodissa
jos siirrät tietoa taulukosta toiseen niin esim.
Range("Taul2!A2")= Ucase( Range("Taul1!A2"))
Poista solulinkki ja kokeile

Private Sub ComboBox1_Change()
Range("B2") = ComboBox1.List(ComboBox1.ListIndex)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Range("H:H").Interior.ColorIndex = xlNone
Range("H9").Interior.ColorIndex = 56
End Sub
en nyt saa tota taul2 sarjaa täsmäämään...
A200=1010
pilkun jälkeen iso kirjain- harmaita hiuksia tuotti, mutta eiköhän toi nyt aika lähellä totuutta... -;)

käytin tota WorksheetFunction.Trim(lause(i)) tossa, jotta se poistaa kaikki ylimääräisetkin välilyönnit lauseesta...

Dim lause As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A11:A12")) Is Nothing Then
Target = UCase(Target)
End If
If Not Intersect(Target, Range("A13: A14")) Is Nothing Then
lause = Split(Target, ".")
For i = 0 To UBound(lause)
lause(i) = WorksheetFunction.Trim(lause(i))
If Len(lause(i)) > 0 Then lause(i) = UCase(Left(lause(i), 1)) & Mid(lause(i), 2)
Next
Target = Join(lause, ". ")
End If
End Sub

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