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. oletuksena nyt eka taulukko, jota testataan

    Private Sub Workbook_BeforePrint(Cancel As Boolean)

    Dim mySolu As Range

    If ActiveSheet.Name = Worksheets(1).Name Then
    For Each mySolu In Range("tarkistaNamaSolut")
    If mySolu = "" Then
    Cancel = True
    MsgBox ("Et voi tulostaa! tietoja puuttuu ")
    Exit Sub
    End If
    Next mySolu
    End If

    End Sub
  2. kysyjä halusikin vain arvot...

    Sub Kopioi()
    On Error Resume Next
    Range("Taul1!B2:M2").Copy 'muuta aluetta tarvittaessa
    Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues) 'kopioi B sarakkeesta alkaen muuta tarvittaessa
    End Sub
  3. Mikä virheilmoitus tulee jos hipsaat On Error Resume Next rivin?
    Ainakin mulla kopioi Taul1 alueen B2:M2 Taul2 aina seuraavalle vapaalle riville B sarakkeessa
  4. "Hmm testasin tuon ja sehän näyttä viimeisestä rivistä seuraavan rivin, eli joudutaan vähentämään yksi rivi pois:"

    offset on 0-pohjainen-eli montako riviä ylä- tai alapuolella sijaitsevaan soluun viittauksen vasemman yläkulman solu viittaa tai montako saraketta vasemmalle tai oikealle viittauksen vasemman yläkulman solu viittaa

    eli tästä johtuen joudut vähentämään -1 tostahan olis helppo tehdä UDF
  5. Sub Kopioi()
    Dim KopioAlue As Range
    On Error Resume Next
    Set KopioAlue = Range("Taul1!B2:M2")'muuta aluetta tarvittaessa
    KopioAlue.Copy Destination:=Range("Taul2!B65536").End(xlUp).Offset(1, 0) 'kopioi B sarakkeesta alkaen muuta tarvittaessa
    End Sub
  6. http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000024055562

    vastasin siellä... ;-)
    http://www.appspro.com/Utilities/ChartLabeler.htm

    Helpoin tapa on ladata joku XY Chart Labeler esim. www.appspro.com
  7. tekee just sen mitä pyytelet

    moduuliin...
    Sub KopioiPoista()
    Dim vika As Integer
    Dim vika2 As Integer
    Dim vika3 As Integer
    Dim i As Integer
    On Error Resume Next
    vika = Range("A65536").End(xlUp).Row
    For i = vika To 1 Step -1
    If i = 1 Then Exit Sub
    If Range("A" & i) = Range("A" & i).Offset(-1, 0) Then
    vika2 = Range("A" & i).End(xlToRight).Column
    vika3 = Range("A" & i).Offset(-1, 0).End(xlToRight).Column
    Range("B" & i).Resize(1, vika2 - 1).Copy Destination:=Range("A" & i).Offset(-1, vika3)
    Range("A" & i).EntireRow.Delete
    End If
    Next
    End Sub
  8. Apuohjelmalla vaan saat tehtyä vippaskonsteja ja originaali kaavio tallentuu ihan normaalisti. Jos avaat sen ilman apuohjelmaa no problems...
  9. http://www.appspro.com/Utilities/ChartLabeler.htm
  10. lue tuolta

    http://www.jkp-ads.com/Articles/RegisterUDF00.htm
  11. muistaakseni argumenteille melko hankala tehdä helppiä, voi olla, että uusimmassa versiossa sekin mahdollista, mutta jotakin voi tehdä sentään helpostikin

    moduuliin...

    Sub Auto_Open()
    Dim kuvaus As String
    kuvaus = "Laskee pari lukua yhteen "
    Application.MacroOptions Macro:="Testi", Description:=kuvaus, Category:=9
    End Sub
    Public Function Testi(ByRef Luku1 As Integer, _
    ByRef Luku2 As Integer) As Integer
    Testi = Luku1 + Luku2
    End Function

    Private Sub Auto_Close()
    Application.MacroOptions Macro:="Testi", Description:=Empty, Category:=Empty
    End Sub
  12. vaikeampi tapa ilman koodia ja helpompi koodilla

    ilmankoodia

    1.Tallenna työkirja web sivuna
    2. Lisää kommentti soluun
    3. Tuplaklikkaa kommentin reunan päällä, missä on niitä palloja
    4.Lomakkeelta valitse Colors and Lines
    5. Color alasvetovalikosta valitse Fill Effects
    6. valitse Picture
    7. Klikkaa Select Picture
    8.Liitä kaaviokuva websivun liitekansiosta
    9. ok
    10.ok


    koodilla
    moduuliin...

    Sub LisaaKaavio()
    Dim alue As Range
    Dim muoto As Object
    Set alue = ActiveCell
    If Not alue.Comment Is Nothing Then
    alue.Comment.Delete
    End If
    ActiveSheet.ChartObjects(1).Activate
    ActiveChart.Export Filename:="C:\KommenttiKaavio.gif", FilterName:="GIF"
    Set muoto = alue.AddComment("")
    muoto.Shape.Fill.UserPicture "C:\KommenttiKaavio.gif"
    Range("A1").Select 'kaavion valinnan poisto
    End Sub
  13. siellä keeroin miten useampi rivisiä comboja tehdään
    mutta kertauksesi:
    BoundColumn siihen sen sarakkeen numero minkä haluat näkyvän
    ColumCount tietojen sarakkeiden määrä
    ColumnWidths esim 10;10;10;0 4 sarakkeelle ja viimeistä ei näytetä
    ListFillRange alue mistä haetaan tiedot esim 4 saraketta A1:D100

    ja sitten koodi objektiin
    Private Sub ComboBox1_Change()
    Range("A1") = ComboBox1.Column(0) ' eka sarake
    Range("B1") = ComboBox1.Column(1) 'toka jne
    Range("C1") = ComboBox1.Column(2)
    Range("D1") = ComboBox1.Column(3)
    End Sub

    ei se ton vaikeempaa ole

    keeep Exceling ;-)
  14. käyttää win API komentoa sleep ja aika annetaan millisekunteina eli 1000= 1 s

    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

    Private Sub Commandbutton1_Click()
    MsgBox "hei"
    Sleep 1000
    MsgBox "moro"
    End Sub
  15. kopioi tiedot Taul2
    Range("A2:A4").Copy Range("Taul2!A65536").End(xlUp)

    tyhjentää tiedot Taul1
    Range("Taul1!A1:A4")=""
  16. tutkailin useita variaatioita, mutta ei taida onnistua ilman VBA:ta tämäkään juttu. Sen avulla se onkin piece of cake

    eli kun D6 syötetään jotakin C1 tulee tämän päivän päiväys ja kun D6 on tyhjä on myös C1 tyhjä

    taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("D6")) Is Nothing Then
    If Not Range("D6") = "" Then
    With Range("C1")
    .Value = Date
    .EntireColumn.AutoFit
    End With
    Else
    Range("C1") = ""
    End If

    End If
    End Sub
  17. lomakkeen moduuliin...

    ja kaikki nimet nyt oletusnimiä ja alueet nimetty checkbox captionin nimillä työkirjassa esim Alue1, Alue2 jne

    Option Explicit
    Dim ctl As Control
    Public MyMulti As Range
    Sub MaaritaAlue()
    Set MyMulti = Nothing
    On Error Resume Next
    For Each ctl In UserForm1.Controls
    If TypeName(ctl) = "CheckBox" Then
    If ctl.Value = True Then
    If MyMulti Is Nothing Then
    Set MyMulti = Range(ctl.Caption)
    Else
    Set MyMulti = Application.Union(MyMulti, Range(ctl.Caption))
    End If
    End If
    End If
    Next
    'MsgBox MyMulti.Address
    End Sub

    Private Sub CheckBox1_Click()
    MaaritaAlue
    End Sub

    Private Sub CheckBox2_Click()
    MaaritaAlue
    End Sub

    Private Sub CheckBox3_Click()
    MaaritaAlue
    End Sub

    Private Sub CheckBox4_Click()
    MaaritaAlue
    End Sub

    Private Sub CommandButton1_Click()
    On Error GoTo virhe
    MyMulti.Select
    'Me.Hide
    'ActiveSheet.PrintPreview False
    Exit Sub
    virhe:
    MsgBox "sinun täytyy valita ainakin yksi alue tulostusta varten!", vbInformation
    End Sub
  18. hakee nyt Taul1 ja Taul2 A-sarakkeen tiedoista Taul3 A-sarakkeeseen uniikit tiedot

    moduuliin...

    Sub Uniikit()
    Dim Vika As Double
    Dim eka As Range
    Dim toka As Range
    On Error Resume Next

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Worksheets("Taul1").Activate
    Vika = Range("A65536").End(xlUp).Row
    Set eka = Range("A1:A" & Vika)

    Worksheets("Taul2").Activate
    Vika = Range("A65536").End(xlUp).Row
    Set toka = Range("A1:A" & Vika)

    Sheets("Huuhaa").Delete
    Worksheets.Add().Name = "Huuhaa"
    Worksheets("Huuhaa").Activate
    Range("A:A") = ""
    Range("A1") = "uniikit"
    eka.Copy Range("A2")
    Vika = Range("A65536").End(xlUp).Row + 1
    toka.Copy Range("A" & Vika)

    Worksheets("Taul3").Activate
    Sheets("Huuhaa").Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
    Range("A1").Select
    Sheets("Huuhaa").Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    Set eka = Nothing
    Set toka = Nothing
    End Sub

    Keep Excelling :-)
  19. Lisää ohjausobjekti valikosta luetteloruutu ja muokkaa sen ominaisuuksia.
    esim. sun tapauksessa vaikka näin

    BoundColumn=2 (arvot toisesta sarakkeesta)
    ColumCount=2 (montako saraketta tietoja)
    ColumWidths= 10pt;0pt
    LinkedCell=C1 (solun osoite , missä tiedot näytetään)
    ListFillRange=A1:B10 (alue missä tiedot on)

    ja siinäpä se!
    Keep Excelling ;-)
  20. tosiaan excel ei aina päivitä viimeistä solua ja tossa alempana tulikin vinkki siihen miten sen saa päivittämään viimeisen solun ja siten siis CTRL+ END toimii oikein. eli deletoi tyhjat rivit ja sarakkeet alueen ulkopuolelta ja tallentaa tiedoston

    Tutkailin asiaa VBA:n kannalta ja seuraava koodi pakottaa excelin päivittämään viimeisen solun. Tosin samalla katoaa Undo muisti... (mutta niinhän se katoaa tallennuksessakin)
    eka koodi resetoi aktiivisen taulukon vika solun ja toka koodi tekee sen kaikille taulukoille ennen tallennusta ja näin ollen estää tiedoston turhan kasvun samalla

    lisää ThisWorkbook moduuliin...

    Private Sub Workbook_SheetSelectionChange _
    (ByVal Sh As Object, ByVal Target As Excel.Range)
    vika= Sh.UsedRange.Rows.Count
    End Sub

    Private Sub Workbook_BeforeSave _
    (ByVal SaveAsUI As Boolean, Cancel As Boolean)
    For Each Sh In ThisWorkbook.Worksheets
    vika= Sh.UsedRange.Rows.Count
    Next Sh
    End Sub

    keep exceling :-)
    21. 65 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt