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
- mutta VBA ja Kunde jeesaa... ;-)
taulukon moduuliin...
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If InStr(1, Target, ",") > 0 Then
Target.NumberFormat = "0.0"
Else
Target.NumberFormat = "0"
End If
Application.EnableEvents = True
End Sub
Keep EXCELing
@Kunde - piti olla
vika=Range("O65536").End(xlUp).Row - vika=Range("A65536").End(xlUp).Row
ActiveChart.SeriesCollection(1).Values =Worksheets("Raportti_APU'").Range("O6:O"& vika)
`
Keep EXCELing
@Kunde - jos esim. A-sarakkeessa tietoja, niin hakee vikan solun alhaalta ylöspäin, eli voi olla välissä tyhjiäkin arvoja
vika=Range("A65536").End(xlUp).Row
ja tietoalue silloin esim. Range("A100:A" & vika)
vastaavasti ylhäältä päin (stoppaa ekaan tyhjään ruutuun, eli ei voi olla tyhjiä välissä...)
vika=Range("A1").End(xlDown).Row
ja tietoalue silloin esim. Range("A100:A" & vika)
Keep EXCELing
@Kunde - pystyy VBA:lla...
ilmeisesti kysyjä haluaa riveillä olevat arvot lajiteltavan dynaamisesti? - Sub poistaRivit()
On Error Resume Next
Rows(Range("B8") & ":" & Range("B9")).Delete
End Sub
Keep EXCELing
@Kunde - vaatii VBA koodin...
haulla löytyy mun tekemiä makroja tästä foorumista - Sub Järjestä()
Dim alue As Range
Dim solu As Range
Dim EiTuplat As New Collection
Dim i As Integer
On Error Resume Next
Range("A:A") = ""
Set alue = Union(Range("B1", Range("B1").End(xlDown)), Range("C1", Range("C1").End(xlDown)), Range("D1", Range("D1").End(xlDown)))
For Each solu In alue
EiTuplat.Add solu.Value, CStr(solu.Value)
Next
On Error GoTo 0
For i = 1 To EiTuplat.Count
Cells(i, 1) = EiTuplat(i)
Next
Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending
End Sub
Keep EXCELing
@Kunde - tee lista perustuen 2 edelliselle valinnalle esim. ltk1_koivu ltk2_koivu ;-)
- http://www.contextures.com/xlDataVal02.html
ton linkin ohjeilla tein 5 alavalikkoa nimeämällä vain ehtoalueet ja epäsuoraa funktiota alaotsikoissa käyttäen...
lipasto -materiaali-vedin-vetimenkoko-vetimenväri...
Keep EXCELing
@Kunde - Alkuperäinen pätkä:
Lista = Sheets("Sheet1").Range("B50", Sheets("Sheet1").Range("B60").End(xlUp))
..listaa vain rivit B49:B50, eli yhtä riviä liian ylhäältä ja vain kaksi kohdetta.
Käytössäni on Excel 2003 versio, olisiko sillä vaikutusta asiaan?
EI
Sheets("Sheet1").Range("B60").End(xlUp)
ko. koodin pätkä valitsee solun B49 eli sinulla on solussa B49 joku arvo jolloin valinnaksi tulee koodissa Lista = Sheets("Sheet1").Range("B50", Sheets("Sheet1").Range("B60").End(xlUp)) B50:B49...
eli muutat sitä arvoa B61 tai tarpeeksi kauaksi. Tietenkin jos sulla listat allekkain silloin ainut keino on hard codeta ne tyyliin Lista = Sheets("Sheet1").Range("B50:B60") kuten olet tehnyt
no haasteeseen sitten...
ei siinä tartte kummosta lisäystä
Option Explicit
Sub Täytä()
Dim OLEobj As Object
Dim Lista1 As Variant
Dim Lista2 As Variant
Dim Lista3 As Variant
Lista1 = Sheets("Sheet1").Range("B50", Sheets("Sheet1").Range("B600").End(xlUp))
Lista2 = Sheets("Sheet1").Range("C50", Sheets("Sheet1").Range("C600").End(xlUp))
Lista3 = Sheets("Sheet1").Range("D50", Sheets("Sheet1").Range("D600").End(xlUp))
For Each OLEobj In ActiveSheet.OLEObjects
If TypeName(OLEobj.Object) = "ComboBox" Then
Select Case Mid(OLEobj.Name, 9)
Case 1 To 10
OLEobj.Object.List = Lista1
Case 11 To 20
OLEobj.Object.List = Lista2
Case 21 To 30
OLEobj.Object.List = Lista3
End Select
End If
Next OLEobj
End Sub
keep EXCELing
@Kunde - vaihda taulukon nimi sopivaksi ja luetteloalue nyt A1:AXXXXXX
Option Explicit
Sub Täytä()
Dim OLEobj As Object
Dim Lista As Variant
Lista = Sheets("Sheet1").Range("A1", Sheets("Sheet1").Range("A65536").End(xlUp))
For Each OLEobj In ActiveSheet.OLEObjects
If TypeName(OLEobj.Object) = "ComboBox" Then
OLEobj.Object.List = Lista
End If
Next OLEobj
End Sub
Keep EXCELing
@Kunde - kokeiles näitä
Sub Palauta()
Worksheets("Sheet1").Activate' vaihda taulukon nimi
Columns("C:C").Select ' sarake C tulee aktiiviseksi
Selection.Copy ' tälle riville ei enää päästä
End Sub
Sub Palauta()
ActiveSheet.Columns("C:C").Select ' sarake C tulee aktiiviseksi
Selection.Copy ' tälle riville ei enää päästä
End Sub
Keep EXCELing
@Kunde - esim. noissa selkeet ohjeet...
http://www.contextures.com/xlDataVal02.html
http://www.myonlinetraininghub.com/excel-data-validation-with-dependent-lists
Keep EXCELing
@Kunde - laita koodi näytille, niin helpottaa kummasti virheen arvuuttelua ;-)
Keep EXCELing
@Kunde - yksinkertaisimmillaan näin ...
etusivun nimi=Varasto
omat myynnit nimi=Myynnit
omat ostot nimi =Ostot
Myynnit taulukot moduuliin...
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Worksheets("Varasto").Range(Target.Address)
.Value = .Value - Target.Value
End With
End Sub
Ostot taulukon moduuliin...
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Worksheets("Varasto").Range(Target.Address)
.Value = .Value Target.Value
End With
End Sub
ei oo virhetarkasteluja ja syöttösolun tarkistuksia, mutta nehän on helppo lisätä....
Keep EXCELing
@Kunde - =LEFT(A1;FIND(" ";A1;1))&MID(MID(MID(SUBSTITUTE(A1;" ";"^";2);1;256);FIND("^";SUBSTITUTE(A1;" ";"^";2));256);2;FIND(" ";MID(MID(SUBSTITUTE(A1;" ";"^";2);1;256);FIND("^";SUBSTITUTE(A1;" ";"^";2));256))-2)
VBA:lla
moduuliin...
Function HaeSanat(Solu As Range, Sana1 As Integer, Sana2 As Integer, Erotin As String) As String
Dim a
a = Split(Solu, Erotin)
HaeSanat = a(Sana1 - 1) & " " & a(Sana2 - 1)
End Function
ja soluun mihin haluat tuloksen kaava
=HaeSanat(A1;1;3;" ")
hakee nyt solusta A1 ekan ja kolmannen sanan erottimena välilyönti
Keep EXCELing
@Kunde - tossapa vastaus kyssäreihin...
Sub Suojaa()
' poistaa taulukon suojauksen salasanalla
ActiveSheet.Unprotect "kunde"
' tsekkaa onko alue tyhjä
If Application.WorksheetFunction.CountA(Range("A6:D6")) > 0 Then
MsgBox "alueella on tietoa"
Else
MsgBox "alue on tyhjä"
End If
' suojaa taulukon salasanalla
ActiveSheet.Protect "kunde"
End Sub
Keep EXCELing
@Kunde - Kyssäri1
moduuliin...
Option Explicit
Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range
Dim solu As Range
Dim EkaOsoite As String
Worksheets("Sheet1").Activate
With HakuAlue
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ä(Range("A4"), Range("A7:A500"))
Löydetty.EntireRow.Delete
Exit Sub
virhe:
MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
End Sub
Kyssäri2
=VLOOKUP(A6;INDIRECT("A9:A501");1;FALSE)
=SUM(INDIRECT("C9:C501"))
Keep EXCELing
@Kunde - ko. taulukon moduuliin(jompi kumpi ei molempia).,,,
jos taulukko aktivoidaan niin silloin päiväys kirjoitetaan (ei päivity jos taulukko on aktiivinen ja tallennat sen ja avaat uudelleen huomenna niin sama päiväys(eli vaatii avauksessa jonkun tietyn sivun aktivoimisen aluksi(pääsivu)...)
Private Sub Worksheet_Activate()
Range("C1") = Date
End Sub
tai jos haluat, että kun muutoksia tehdään
Private Sub Worksheet_Change(ByVal Target As Range)
Range("C1") = Date
End Sub
Keep EXCELing
@Kunde