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
- hiiren oikeaan valikkoon kelpoisuusehto
moduuliin...
Sub TeeValikko()
Dim ctrl As CommandBarControl
Dim btn As CommandBarControl
Dim i As Long
Dim Vika As Long
PoistaMenu
Set ctrl = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup, before:=1)
'muuta otsikko sopivaksi
ctrl.Caption = "Kelpoisuusehdot..."
Vika = Range("H65536").End(xlUp).Row
i = 1
'kelpoisuusehto alue , muuta sopivaksi
For Each solu In Range("H1:H" & Vika)
Set btn = ctrl.Controls.Add
btn.Caption = solu
btn.Tag = i
btn.OnAction = "LisääKelpoisuusehto"
i = i 1
Next
End Sub
Private Sub LisääKelpoisuusehto()
ActiveCell = Application.CommandBars.ActionControl.Caption
End Sub
'poistaa tiedot hiiren okeasta valikosta
Sub PoistaMenu()
Dim ctrl As CommandBarControl
For Each ctrl In Application.CommandBars("Cell").Controls
If ctrl.Caption = "Lisää tekstit..." Then ctrl.Delete
Next
End Sub
Keep EXCEling
@Kunde - =OR(J1<=8;J1=25)*3 AND(J1<=11;J1>=9)*1 AND(J1<=24;J1>=21)*2
Keep EXCELing
@Kunde - lähetä taulukko hmetso(at)hotmail.com ja mallia mitä haluat, niin voin vilkaista ja kertoa tarkemmin
- Riippuu siitä miten olet koodin tehnyt.
Jos et halua poistaa jo tehtyä vektoreita hipsaa moduulin koodissa poista funktion kutsu tai nimeä nimeä vektorit siten, että niitä on helppo hallita, lisäämällä eteen vaikka jonkun erikoismerkin (esimerkkikoodissa @- merkki eteen)...
Funktiot voi käsitellä useampia vektoreita kerrallaan. En tiedä mitä haluat tehdä ja minkälainen on taulukkosi, joten koodi vain ihan peruspiirtoon. Jos haluat laskea vektoreita yhteen laskea vektoreiden välisiä kulmia yms. , niin clsVektori moduulissa vaan lisätään ominaisuuksia vektoreille ja hiukkasen matematiikkaa... ;-)
Sub Poista()
Dim Shp As Shape
On Error Resume Next
For Each Shp In ActiveSheet.Shapes
If Not Shp.Name Like "@*" Then Shp.Delete
Next Shp
End Sub
Keep EXCELing
@Kunde - tavalliseen moduuliin...
Option Explicit
Sub Poista()
Dim Shp As Shape
On Error Resume Next
For Each Shp In ActiveSheet.Shapes
Shp.Delete
Next Shp
End Sub
Sub PiirräVektori()
Poista
Dim Vektori1 As New ClsVektori
With Vektori1
'jos käytät muuta kuin Vektoriluokan oletusta aloituspisteelle, niin hipsaa allaolevat 2 riviä...
' .x1 = ActiveSheet.Range("P18").Left
' .y1 = ActiveSheet.Range("P18").Top
' pituus
.Pituus = Range("A1").Value
' kulma
.Kulma = Range("A2").Value
' skalaari
.Skalaari = 10
.Nimi = "Vektori1"
.Piirrä
End With
End Sub
lisää luokka moduuli ja nimeä se ClsVektori ja lisää allaoleva koodi sinne
Oletuksia voi lisätä ja ominaisuuksia lisäillä tarpeen mukaan
Option Explicit
Public x1 As Double
Public y1 As Double
Public Kulma As Double
Public Pituus As Double
Public Skalaari As Double
Public Viivanväri As Integer
Public Viivanpaksuus As Double
Public Nimi As String
Public Pi As Double
Private Sub Class_Initialize()
' oletusarvoja
x1 = 200
y1 = 200
Kulma = 0
Pituus = 10
Skalaari = 1
Pi = 3.14159265358979
Viivanväri = 8
Viivanpaksuus = 1
End Sub
Private Function Rad(Asteet As Double) As Double
Rad = Asteet * Pi / 180
End Function
Function x2() As Double
x2 = x1 Pituus * Sin(Rad(Kulma)) * Skalaari
End Function
Function y2() As Double
y2 = y1 - Pituus * Cos(Rad(Kulma)) * Skalaari
End Function
Sub Piirrä()
With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2)
.Name = Nimi
.Line.EndArrowheadStyle = msoArrowheadStealth
.Line.BeginArrowheadStyle = msoArrowheadNone
.Line.ForeColor.SchemeColor = Viivanväri
.Line.Weight = Viivanpaksuus
End With
End Sub
Keep EXCELing
@Kunde - Oikeastihan vektorille annetaan suuntakulma ja pituus
Voin tehdä makron tommoselle jos haluat... ;-)
Jos haluat jotain muutakin, niin kerro ja lisätään sitten makroon
Function Viiva1(x As Double, y As Double) As Double
Dim xlShp As Shape
Set xlShp = ActiveSheet.Shapes.AddLine(ActiveSheet.Range("P18").Left, ActiveSheet.Range("P18").Top, x, y)
xlShp.Line.BeginArrowheadStyle = msoArrowheadNone
xlShp.Line.EndArrowheadStyle = msoArrowheadStealth
End Function
ActiveSheet.Shapes("Kundenmalli").Delete
Keep EXCEling
@Kunde - Laitoin malliksi hieman muitakin juttuja, mitä voi hyödyntää. On toki paljon muitakin vielä. Itsellä oli tarve lisätä paljon attribuuttitietoa (mm poraukset) ja Excelissä ei semmoista ole objekteilla mutta aika kivuttomasti se tollainkin meni...
Tein myöhemmin sitten treeviewllä yksinkertaisen rakennepuun, missä osia pystyy muokkaaman vapaasti.
APIlla sitten lomakkeellaoli helpompaa fiksailla kaikkea ja näkee piirron kanssa samalla, mutta ihan toimiva juttu ja todistaa sen, että EXCEL taipuu moniin juttuihin, mihin sitä ei le alunperin edes tarkoitettu ;-)
Sub Suorakaide(X As Double, Y As Double, Leveys As Double, Korkeus As Double)
Dim a
Dim xlShp As Shape
Worksheets(1).Activate
'soluun kiinnitettynä
Set xlShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveSheet.Range("C10").Left, ActiveSheet.Range("c10").Top, Leveys, Korkeus)
'vasemmasta yläkulmasta lähtien
'Set xlShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, X, Y, Leveys, Korkeus)
With xlShp
.Name = "Kundenmalli"
'tässä voi lisätä atribuuttitietoja vaihtoehtoinen teksti attribuuttiin, josta voi lukea sitten kätevästi tuotteen tietoja tai indoa
.AlternativeText = .Name & "," & Korkeus & "," & Leveys & ",Tammi"
'tässä voi kätevästi näyttää tuotteen tiedot hyperlinkillä kun hiirellä siirtyy kuvion päälle
a = Split(.AlternativeText, ",")
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes(.Name), Address:="", ScreenTip:="Osan nimi: " & a(0) & vbNewLine & "Korkeus: " & a(1) & vbNewLine & "Leveys: " & a(2) & vbNewLine & "Väri: " & a(3)
'tässä voi lisätä materiaalin tai värin
' .Fill.UserPicture ThisWorkbook.Path & "\" & "Tammi.jpg"
.Line.Visible = msoTrue
.Line.Weight = 0
End With
'viiva
Set xlShp = ActiveSheet.Shapes.AddLine(ActiveSheet.Shapes("Kundenmalli").Left ActiveSheet.Shapes("Kundenmalli").Width, ActiveSheet.Shapes("Kundenmalli").Top ActiveSheet.Shapes("Kundenmalli").Height, 500, 500)
xlShp.Select
xlShp.Name = "Viiva"
End Sub
Sub Koe()
'tiedot voi hakea solustakin
'Suorakaide Range("A1"), Range)"B1"), Range("C1"), Range("D1")
Suorakaide 100, 100, 100, 500
End Sub
Keep EXCELing
@Kunde - Kyllä pystyy piirtämään kuvioilla sekä viivoilla täysin parametrisesti ja lisäämään teksturit kanssa.
Itse olen tehnyt parit kalusteiden suunnitteluohjelmat, joissa piirretään parametreillä.
Lisätään esim. komeron aukkoihin erilaisia objekteja kuten hyllyjä, laatikoita, koreja ja erilaisia settejä yms ja ohjelma tekee myös tarvittavat CNC koodit komeronosille. Eli täysi paketti tilauksesta tuotantoon... ;-)
Keep EXCELing
@Kunde - Oma funktio
koodi tavalliseen moduuliin...
laita soluun, mihin haluat tuloksen kaava
laskee nyt tunnit päiväyksistä alueelta E1:E10
=LaskeTunnitPäiväyksestä(E1:E10)
Function LaskeTunnitPäiväyksestä(Alue As Range) As Double
Dim Tunnit
Dim Summa As Double
For Each Solu In Alue
LaskeTunnitPäiväyksestä = LaskeTunnitPäiväyksestä CDate(Solu) - Int(CDate(Solu))
Next
LaskeTunnitPäiväyksestä = LaskeTunnitPäiväyksestä * 24
End Function
keep EXCELing
@Kunde - Aika pahan kyssärin heitit ;-)
Taulukon nimen muutokselle ei löydy tapahtumaa, mutta kikkailemalla sekin syntyi...
Vanhalla EXCEL4 macrolla homma hoituikin
ThisWorkbook moduuliin...
Option Explicit
Private Sub PäivitäTaulukonNimi()
ActiveSheet.Range("A1").Formula = _
"=MID(CELL(""filename""," & _
ActiveSheet.Name & "!A1" & _
"),FIND(""]"",CELL(""filename""," & _
ActiveSheet.Name & "!A1" & _
")) 1,255)"
End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
On Error Resume Next
Application.EnableEvents = False
PäivitäTaulukonNimi
Application.EnableEvents = True
End Sub
Sub Reset()
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Keep EXCELing
@Kunde - Ihan turhaa kirjoitella joka taulukolle omaa makroa
Fiksumpi tapa
ThisWorkbook moduuliin...
tsekataan , että vain A1 on muuttunut
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Sh.Range("A1")) Is Nothing Then
Sh.Name = Sh.Range("A1")
End If
End Sub - " Siinä voi helposti tulla tilanteita missä tämän päivän ranking poikkeaisi aika paljonkin huomenna saman ihmisen tekemästä rankingista."
Siksipä mä tommosen koodin rustasin, että voi tehdä muutoksia ja lista elää tilanteen mukaan... ;-) - lipsahti ekaksi fiksaamaton koodi tässä oikea...
edelliset postaukset eivät huomioi sitä , että jos esim. ne 100 lukua , niin hankalaa muistaa mitä lukuja on jo käyttänyt , koska luvut eivät poistu luettelosta.
Lisähaasteena tossa vielä sekin, että jos haluaa muuttaa jo solussa olevaa lukua vanha luku pitää palauttaa ja poistaa uusi luku listasta...
no tossa koodi...
nyt kelpoisuusehto H1:H100 ja luvut Ki:K100 , muuta sopivaksi
ko taulukon moduuliin...
Dim Vanhasolu As Variant
Dim Uusisolu As Variant
Public TyhjäSolu As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Range("H1:H100"), Target) Is Nothing Then
If Target.Count = 1 Then
If Target = "" Then
TyhjäSolu = True
Else
TyhjäSolu = False
End If
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
Application.ScreenUpdating = False
If Not Intersect(Range("H1:H100"), Target) Is Nothing And TyhjäSolu Then
PoistaLuettelosta Target
ActiveWorkbook.Names("Lista").Delete
vika = Range("K1").End(xlDown).Row
If Not Range("K1") = "" Then
ActiveWorkbook.Names.Add Name:="Lista", RefersTo:=Range("K1:K" & vika)
Else
Range("H1:H100").Validation.Delete
End If
Else
If Not Intersect(Range("H1:H100"), Target) Is Nothing And Not TyhjäSolu Then
Uusisolu = Target.Value
Application.Undo
Vanhasolu = Target.Value
ActiveWorkbook.Names("Lista").Delete
vika = Range("K1").End(xlDown).Row
Range("K" & vika 1) = Vanhasolu
ActiveWorkbook.Names.Add Name:="Lista", RefersTo:=Range("K1:K" & vika 1)
Worksheets("Sheet1").Sort.SortFields.Clear
Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("K1:K" & vika 1), Order:=xlAscending
With Worksheets("Sheet1").Sort
.SetRange Range("K1:K" & vika 1)
.Apply
End With
Target = Uusisolu
Vanhasolu = Uusisolu
PoistaLuettelosta Uusisolu
End If
End If
TyhjäSolu = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
tavalliseen moduuliin...
Sub resetoi()
Application.EnableEvents = True
Application.ScreenUpdating = True
TyhjäSolu = False
ActiveWorkbook.Names.Add Name:="Lista", RefersTo:=Range("K1:K100")
Range("K1") = 1
Range("K2") = 2
Range("K1:K2").AutoFill Destination:=Range("K1:K100"), Type:=xlFillDefault
Range("H1:H100") = ""
With Range("H1:H100").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$K$1:$K$100"
End With
End Sub
Sub PoistaLuettelosta(Hakuehto As Variant)
Worksheets("Sheet1").Activate
Dim solu As Range
With Range("K1:K100")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
solu.Delete shift:=xlUp
End If
End With
Worksheets("Sheet1").Sort.SortFields.Clear
Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("K1:K100"), Order:=xlAscending
With Worksheets("Sheet1").Sort
.SetRange Range("K1:K100")
.Apply
End With
End Sub
Keep EXCELing
@Kunde - edelliset postaukset eivät huomioi sitä , että jos esim. ne 100 lukua , niin hankalaa muistaa mitä lukuja on jo käyttänyt , koska luvut eivät poistu luettelosta.
Lisähaasteena tossa vielä sekin, että jos haluaa muuttaa jo solussa olevaa lukua vanha luku pitää palauttaa ja poistaa uusi luku listasta...
no tossa koodi...
nyt kelpoisuusehto H1:H100 ja luvut Ki:K100 , muuta sopivaksi
ko taulukon moduuliin...
Dim Vanhasolu As Variant
Dim Uusisolu As Variant
Public TyhjäSolu As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Range("H1:H10"), Target) Is Nothing Then
If Target.Count = 1 Then
If Target = "" Then
TyhjäSolu = True
Else
TyhjäSolu = False
End If
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
Application.ScreenUpdating = False
If Not Intersect(Range("H1:H10"), Target) Is Nothing And TyhjäSolu Then
PoistaLuettelosta Target
ActiveWorkbook.Names("Lista").Delete
vika = Range("K1").End(xlDown).Row
If Not Range("K1") = "" Then
ActiveWorkbook.Names.Add Name:="Lista", RefersTo:=Range("K1:K" & vika)
Else
Range("H1:H100").Validation.Delete
End If
Else
If Not Intersect(Range("H1:H10"), Target) Is Nothing And Not TyhjäSolu Then
Uusisolu = Target.Value
Application.Undo
Vanhasolu = Target.Value
ActiveWorkbook.Names("Lista").Delete
vika = Range("K1").End(xlDown).Row
Range("K" & vika 1) = Vanhasolu
ActiveWorkbook.Names.Add Name:="Lista", RefersTo:=Range("K1:K" & vika 1)
Worksheets("Sheet1").Sort.SortFields.Clear
Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("K1:K" & vika 1), Order:=xlAscending
With Worksheets("Sheet1").Sort
.SetRange Range("K1:K" & vika 1)
.Apply
End With
Target = Uusisolu
Vanhasolu = Uusisolu
PoistaLuettelosta Uusisolu
End If
End If
TyhjäSolu = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
tavalliseen moduuliin...
Sub resetoi()
Application.EnableEvents = True
Application.ScreenUpdating = True
TyhjäSolu = False
ActiveWorkbook.Names.Add Name:="Lista", RefersTo:=Range("K1:K100")
Range("K1") = 1
Range("K2") = 2
Range("K1:K2").AutoFill Destination:=Range("K1:K100"), Type:=xlFillDefault
Range("H1:H100") = ""
With Range("H1:H100").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$K$1:$K$100"
End With
End Sub
Sub PoistaLuettelosta(Hakuehto As Variant)
Worksheets("Sheet1").Activate
Dim solu As Range
With Range("K1:K10")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
solu.Delete shift:=xlUp
End If
End With
Worksheets("Sheet1").Sort.SortFields.Clear
Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("K1:K10"), Order:=xlAscending
With Worksheets("Sheet1").Sort
.SetRange Range("K1:K10")
.Apply
End With
End Sub
Keep EXCELing
@Kunde - Sub PoistaTuplat()
Dim Alue As Range
Dim TuplaAlue As Range
Dim Solu As Range
Dim Vika As Long
On Error GoTo virhe
'aktiivisen solun sarake hakusarakkeena
Set Alue = Range(Cells(1, ActiveCell.Column), Cells(Cells(65536, ActiveCell.Column).End(xlUp).Row, ActiveCell.Column))
Alue.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set TuplaAlue = Nothing
For Each Solu In Alue
If Solu.EntireRow.Hidden Then
If Not Solu = "" Then
If TuplaAlue Is Nothing Then
Set TuplaAlue = Solu
Else
Set TuplaAlue = Union(TuplaAlue, Solu)
End If
End If
End If
Next
If Not TuplaAlue Is Nothing Then
TuplaAlue.EntireRow.Delete
Else
Exit Sub
End If
ActiveSheet.ShowAllData
Exit Sub
virhe:
MsgBox "Valitse sarake klikkaamalla haluamasi sarakkeen solua tietoalueelta"
End Sub
Keep EXCELing
@Kunde - unohtui se linkki videolle
https://www.dropbox.com/s/jajgi6oimsjdv44/Suomi24.mp4?dl=0 - vaikeeta vastata kun bannaa mut kokoajan...
tein videon , missä mun 2010 ohjelma toimii ihan Ok
Tsekkaa ja kokeile alla olevalla koodilla ja jos herjaa jotakin, niin infoa
tossa koodi
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim solu As Range
Dim x
'ohitetaan virhetilanteet
On Error Resume Next
'peruutetaan normaalitulostus
Cancel = True
'estetään Excelin reakointi tapahtumiin ja näytön päivitysa pois
Application.EnableEvents = False
Application.ScreenUpdating = False
'muuta ehto sopivaksi
'täsää käydään solualue läpi solu kerrallaan
For Each solu In Range("F4:F100")
'tarkistetaan onko hinta solussa
If Not IsEmpty(solu) Or IsEmpty(solu.Offset(0, -1)) Then
' piilotetaan rivi, jos hinta solussa
solu.EntireRow.Hidden = True
End If
Next
'kopioidaan tiedot alas
Range("130:230").Delete
'jos et halua 1-3 riviä siirtää vaihda hipsun paikka allaolevilla 2 rivillä
'Range("4:100").SpecialCells(xlCellTypeVisible).Copy Range("A130")
Range("1:100").SpecialCells(xlCellTypeVisible).Copy Range("A130")
'Range("4:100").SpecialCells(xlCellTypeVisible).Copy Range("A130")
'määritellään tulostusalue
ActiveSheet.PageSetup.PrintArea = "$A$4:$F$100"
'näytetään tulostuksen esikatselu
ActiveSheet.PrintPreview
x = MsgBox("Tulostetaanko?", vbYesNo, "Tulostus")
If x = 6 Then
'tulostetaan sivu
ActiveWindow.SelectedSheets.PrintOut
End If
'palautetaan piilotetut rivit
Rows("4:100").EntireRow.Hidden = False
'palautetaan Excel normaalitilaan
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Keep EXCELing
@Kunde - melkoista lypsämistä, eikö toiveet voisi esittää kerralla ....
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
If Sh.Index > 2 And Sh.Index < 24 Then
If Not Intersect(Target, Rows("6:20")) Is Nothing Then
Application.EnableEvents = False
If WorksheetFunction.CountA(Target.EntireRow) = 1 Then
Target.Offset(2, 0).EntireRow.Hidden = True
Else
Target.Offset(2, 0).EntireRow.Hidden = False
End If
End If
End If
Application.EnableEvents = True
End Sub
Keep EXCEling - Liitä allaoleva koodi ThisWorkBook(TämäTyökirja) moduuliin ja poista vanha koodi ko.taulukon moduulista.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Rows("6:20")) Is Nothing Then
Application.EnableEvents = False
If WorksheetFunction.CountA(Target.EntireRow) = 1 Then
Target.Offset(2, 0).EntireRow.Hidden = True
Else
Target.Offset(2, 0).EntireRow.Hidden = False
End If
End If
Application.EnableEvents = True
End Sub
Keep EXCELing
@Kunde - muuta koodissa
If WorksheetFunction.CountA(Target.EntireRow) = 1 Then
Keep EXCEling
@Kunde