kunde

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

Aloituksia

7

Kommenttia

1377

  1. 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
  2. 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
  3. 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
  4. 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
  5. 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
  6. kohta2
    2. Valitse valikosta Ikkuna/Kiinnitä ruudut

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

    @Kunde
    Keep Excelling
  8. 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
  9. 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
  10. 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
  11. 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
  12. 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
  13. 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
  14. 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
  15. Private Sub CommandButton5_Click()
    Range("F1").FormulaR1C1 = "=SUM(Summa)"
    End Sub
  16. 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
  17. taulukon moduuliin...
    nyt solussa A1 muutos ja solussa prosentti
  18. 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
  19. 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
  20. solumuotoilulla voi tehdä.
    Muotoilussa on 4 muotoilumahdollisuutta. Positiiviset luvut, negatiiviset luvut, nolla arvo ja teksti. Sektiot erotetaan puolipisteellä, joten sun tapauksessa esim.
    0,00;;;@
    21. 46 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt