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_SelectionChange(ByVal Target As Range)
ActiveSheet.Calculate
End Sub

normaali moduuliin...

Function LaskeLihavoidut(Alue As Range) As Double
Application.Volatile True
For Each solu In Alue
If (Application.WorksheetFunction.IsNumber(solu) = True And solu.Font.Bold = True) Then
LaskeLihavoidut = LaskeLihavoidut + solu
End If
Next
End Function

ja soluun kaava esim. =LaskeLihavoidut(A1:A1000)

Keep Excelling
@Kunde
moduuliin...
muuta sarake sopivaksi. Nyt A-sarakkeesta haetaa tuplia

Sub PoistaTuplat()
Dim solu As Range
Dim Vika As Double
Dim i As Long
Dim EiTupla As New Collection
On Error GoTo virhe
Vika = Range("A65536").End(xlUp).Row
Range("A" & Vika).Select
For i = Vika To 1 Step -1
If Not IsEmpty(ActiveCell) Then
EiTupla.Add ActiveCell.Value, CStr(ActiveCell.Value)
If i = 1 Then Exit For
ActiveCell.Offset(-1, 0).Select
End If
Next
Exit Sub
virhe:
ActiveCell.EntireRow.Delete
Resume Next
End Sub

Keep Excelling
@Kunde
Private Sub tuuli_Click()
Cells(ActiveCell.Row, 20).Value = tuuli.List(tuuli.ListIndex, 1)
Cells(ActiveCell.Row, 20).Select
tuuli.ListIndex = -1
End Sub

koodissa siis käytetään Click tapahtumaa ja se siirtää valinnan Cells(ActiveCell.Row, 20) soluun. Sen jälkeen poistetaan kohdistus combosta siirtämäällä se soluun ja lopuksi poistetaan combosta valinta, eli näin saadan valinta aina toimimaan toisin kuin change tapahtumassa, missä ei siis tapahdu muutosta jos valitaan sama valinta uudestaan ...

Keep Excelling
@Kunde
kun olet lisännyt combon niin tuplaklikkaa sitä ja koodisivu aukeaa ja siihen tulee automaattisesti esim.

Private Sub ComboBox1_Change()
End Sub

nyt vaan lisäät vanhan makron nimen noiden rivien väliin
esim.
Private Sub ComboBox1_Change()
VanhaMakro
End Sub

jossain moduulissa sitten se vanha makro -ei kuitenkaan ThisWorkbook moduulissa muistaakseni...

Sub VanhaMakro()
MsgBox 1
End Sub
jos kelpoisuusehdolla olet tehnyt "drop down "valikon niin esim. zoomkikalla onnistuu...

taulukon moduuliin...
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim OrigZoom As Long
Dim MuutettuZoom As Long
Dim Kelpoisuus As Long

On Error Resume Next
Application.EnableEvents = False

Kelpoisuus = 0
OrigZoom = 100 'muuta originaalizoomausarvoa tässä
MuutettuZoom = 140 'muuta zoomausarvoa tässä
Kelpoisuus = Target.Validation.Type
On Error GoTo virhe
If Kelpoisuus 3 Then
With ActiveWindow
If .Zoom OrigZoom Then
.Zoom = OrigZoom
End If
End With
Else
With ActiveWindow
If .Zoom MuutettuZoom Then
.Zoom = MuutettuZoom
End If
End With
End If
poistu:
Application.EnableEvents = True
Exit Sub
virhe:
GoTo poistu
End Sub

tai sitten jos käytit ohjausobjektia , niin siinähän kanssa ei ole fontin koon säätöä, mutta kikkailemalla taas. Ongelmaksihan voi tulla combon liian iso koko...

combon koodiin seuraavat

Private Sub ComboBox2_GotFocus()
ActiveWindow.Zoom = 140
End Sub

Private Sub ComboBox2_LostFocus()
ActiveWindow.Zoom = 100
End Sub

Keep Excelling
@Kunde
kohta2
2. Valitse valikosta Ikkuna/Kiinnitä ruudut

muitahan ei tartte kääntää kun ovat koodia...
kalenterikontrollilla... mutta ei syytä huoleen
vaihda kontrolli Microsoft Month View kontrolliin ja sen ominaisuuksissa laita ShowWeekNumbers=True

@Kunde
Keep Excelling
ihan hyvät linkit oli annettu...
Tossa nyt koodi, jossa ei tartte aukaista Powerpointia etukäteen tai jos esitys on jo auki -
lisää aktiivisen esityksen loppuun kaaviot...

moduuliin...

Dim powApp As PowerPoint.Application
Dim powPres As PowerPoint.Presentation
Dim powSlide As PowerPoint.Slide
Dim laskuri As Long

Sub KaaviotPowerpointtiin()
' Aseta viittaus Microsoft PowerPoint Object Library
If ActiveSheet.ChartObjects.Count = 0 Then
MsgBox "Aktiivinen taulukko ei sisällä kaavioita!!!", vbInformation
Exit Sub
End If
OnkoPowerpoint = TsekkaaPowerpoint() 'tsekataan onko Powerpoint käynnissä
If OnkoPowerpoint Then
Set powApp = GetObject(, "Powerpoint.Application")
Else
Set powApp = CreateObject("Powerpoint.application")
powApp.Visible = True
End If

If powApp.Presentations.Count = 0 Then
powApp.Presentations.Add
End If


For laskuri = 1 To ActiveSheet.ChartObjects.Count

With ActiveSheet.ChartObjects(laskuri).Chart
.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
End With

If powApp.ActivePresentation.Slides.Count = 0 Then
Set powSlide = powApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
Else
powApp.ActivePresentation.Slides.Add powApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank

End If

powApp.ActiveWindow.View.GotoSlide powApp.ActivePresentation.Slides.Count
Set powSlide = powApp.ActivePresentation.Slides(powApp.ActivePresentation.Slides.Count)
powSlide.Shapes.Paste.Select
powApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
powApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
Next
Set powSlide = Nothing
Set powPres = Nothing
Set powApp = Nothing
End Sub

Function TsekkaaPowerpoint() As Boolean
On Error Resume Next
Set powApp = GetObject(, "Powerpoint.Application")
TsekkaaPowerpoint = (Error.Number = 0)
Set powApp = Nothing
Err.Clear
End Function
Missäs noi 50 kaaviota on työkirjassa?
Samassa taulukossa vaiko eri taulukossa vaiko kaaviosivuilla?
Miten nimetty?
Eiköhän se noilla tiedolla onnistu jo melko helposti
moduuliin...

Sub Tulosta()
Dim vika As Long
Dim i As Integer
vika = Range("Sheet1!A65536").End(xlUp).Row
Worksheets("Sheet2").Activate
For i = 1 To vika
'tähän se solu mihin tietoa haetaan Sheet1:ltä...
Range("C10") = Range("Sheet1!A" & i)
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
DoEvents
Next
End Sub
taulukon moduuliin...
nyt lomake tulee esiin kun klikkaat solua (A1).
muita sopivia vaihtoehtoja olisi esim tuplaklikkaus ja oikea nappi

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
UserForm1.Show
End If
End Sub
taulukon moduuliin...
tietämättä tarkemmin tarvettasi niin tossa nyt 3 eri variaatiota
vain yksi saa olla käytössä kerrallaan

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("B1")) Is Nothing Then
Range("A1") = Range("A1") * Range("B1") / 100
End If
If Not Intersect(Target, Range("A1")) Is Nothing Then
Range("A1") = Range("A1") * Range("B1") / 100
End If
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("B1")) Is Nothing Then
Range("A1") = Range("A1") * Range("B1") / 100
End If
Range("B1") = ""
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("A1")) Is Nothing Then
Range("A1") = Range("A1") * Range("B1") / 100
End If
Application.EnableEvents = True
End Sub
eihän siinä mikään muutu kun samaa lukua yritetään syöttää
vaihda tapahtumaa esim
Private Sub ComboBox1_Click()
ActiveCell = ComboBox1.Value
ActiveCell.Select
ComboBox1.ListIndex = -1
End Sub
valintaruudulle ja vaihto nppulalalle koodit...

Private Sub CheckBox1_Click()
If CheckBox1 Then
CheckBox1.Caption = 1
Range("B5") = 1
Else
CheckBox1.Caption = 0
Range("B5") = 0
End If
End Sub

Private Sub ToggleButton1_Click()
If ToggleButton1 Then
ToggleButton1.Caption = ""
Range("B5") = 0
Else
ToggleButton1.Caption = 1
Range("B5") = 1
End If
End Sub
Private Sub CommandButton5_Click()
Range("F1").FormulaR1C1 = "=SUM(Summa)"
End Sub
moduuliin...
esimerkissä pilkkoo solualueen (taulukko Sheet1) A1:C10 solusta E1 alaspäin
muuttele sopivaksi

Dim i As Integer
Sub Koe(OriginaaliAlue As Range, KopioAlue As Range)
Worksheets("Sheet1").Activate
KopioAlue.Resize(1000, 2) = ""
For Each Row In OriginaaliAlue.Rows
KopioAlue.Select
i = 0
For i = Row.Cells(1, 1) To Row.Cells(1, 2)
KopioAlue = i
KopioAlue.Offset(0, 1) = Row.Cells(1, 3)
Set KopioAlue = KopioAlue.Offset(1, 0)
Next
Next
End Sub
Sub Testi()
Koe Range("A1:C10"), Range("E1")
End Sub
taulukon moduuliin...
nyt solussa A1 muutos ja solussa prosentti
eli liikaa comboja, mihinkäs niitä niin paljon tarvitsee??? Mietipä niiden tarvetta uudelleen ja jos niitä tarttee paljon tee lomake ja combot sitten sinne, niin ei resurssit lopu kesken...
@Kunde
Comboon molemmat sarakkeet ja ominaisuuksissa columcount=2 ja listfillrange F10:G15 . Jos et halua lyhenteitä näkyviin niin Columnwidths tokalle nollaksi esim. 100;0
koodi nyt C1=linkedcell

Private Sub ComboBox1_Change()
Range("C1") = ComboBox1.List(ComboBox1.ListIndex, 1)
End Sub

Keep Excelling
@Kunde
solumuotoilulla voi tehdä.
Muotoilussa on 4 muotoilumahdollisuutta. Positiiviset luvut, negatiiviset luvut, nolla arvo ja teksti. Sektiot erotetaan puolipisteellä, joten sun tapauksessa esim.
0,00;;;@
46 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt