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

1374

  • Uusimmat aloitukset
  • Suosituimmat aloitukset
  • Uusimmat kommentit
  1. ok näin yksinkertaisena tapauksena (yksi väri)
    anteeksi virheeni

    by the way niin se aika vaan rientää
    vastakysymys ;-)

    kuinka teet 6-7 erilaista värimuotoilua solulle ilman koodia (XL2003- uudemmissahan saattaa olla vaihtoehtoja jo useita, mutta tässä versiossa 3 ehdollista muotoilua)
  2. ei onnaa useammalle solulle ilman koodia...

    ko taulukon moduuliin...

    vain solut A1:G1 muuttaa väriä...

    Option Explicit
    Private Sub Worksheet_Change(ByVal Target As Range)
    If Range("G1") = 0 Then
    Range("A1:G1").Interior.ColorIndex = 6
    Else
    Range("A1:G1").Interior.ColorIndex = xlNone
    End If
    End Sub

    tai koko rivi muuttaa väriä...

    Option Explicit

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Range("G1") = 0 Then
    Rows("1:1").Interior.ColorIndex = 6
    Else
    Rows("1:1").Interior.ColorIndex = xlNone
    End If
    End Sub

    Keep EXCELing
    @Kunde
  3. pikkusen foorumilla hakua peliin ja vastaavia kyssäreitä löytyy ja mun vastaukset niihin, ei tartte kuin sarakkeita ja nimiä muutella...

    moduuliin...

    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ä = solu
    EkaOsoite = solu.Address
    Do
    Set EtsiJaSiirrä = Union(EtsiJaSiirrä, solu)
    Set solu = .FindNext(solu)
    Loop While Not solu Is Nothing And solu.Address EkaOsoite
    End If
    End With
    End Function

    Sub EtsiijaPoistaa()
    Dim vika As Long
    On Error Resume Next
    vika = Worksheets("Sheet2").Range("D65536").End(xlUp).Row
    For Each solu In Worksheets("Sheet2").Range("D1:D" & vika)
    EtsiJaSiirrä(solu, Columns("A:A")).EntireRow.Delete
    Next
    End Sub

    Keep EXCELing
    @Kunde
  4. lisää viittaus Microsoft Scripting Runtime

    moduuliin...

    Sub HaePDf()
    Dim FSO As Scripting.FileSystemObject
    Dim LähdeKansio As Scripting.Folder
    Dim Tiedosto As Scripting.File
    Range("A:A") = ""
    Range("A1").Select
    Set FSO = New Scripting.FileSystemObject
    Set LähdeKansio = FSO.GetFolder("E:\Testi\")
    For Each Tiedosto In LähdeKansio.Files
    If Right(Tiedosto, 4) = ".pdf" Then
    ActiveCell = Left(Tiedosto.Name, Len(Tiedosto.Name) - 4)
    ActiveCell.Offset(1, 0).Select
    End If
    Next Tiedosto
    Columns("A:A").AutoFit
    Set Tiedosto = Nothing
    Set LähdeKansio = Nothing
    Set FSO = Nothing
    End Sub


    Keep EXCELing
    @Kunde
  5. tekee sarjan aktiivisesta saolusta alaspäin...

    moduuliin...

    Sub Sarja()
    Dim i As Long
    For i = 1457 To 1876
    ActiveCell = "KLF" & i & "-11"
    ActiveCell.Offset(1, 0).Select
    Next
    End Sub

    Keep EXCELing
    @Kunde
  6. kaavion teko ohjetta en ymmärtänyt...
    moduuliin...

    Option Explicit

    Sub Siirrä()
    Dim vika As Long
    Worksheets("Sheet1").Activate
    vika = Range("G65536").End(xlUp).Row
    Worksheets("Sheet2").Columns("A:B") = ""
    Worksheets("Sheet1").Range("G1:G" & vika).Copy Worksheets("Sheet2").Range("A1")
    Worksheets("Sheet1").Range("B1:B" & vika).Copy Worksheets("Sheet2").Range("B1")
    Worksheets("Sheet2").Activate
    Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    ' kaavionteko
    End Sub


    Keep EXCELing
    @Kunde
  7. helpistähan noi löytyi heti.
    tossa nyt yleisimmät variaatiot...

    Sub Sivunumerot()
    ActiveDocument.Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberLeft)
    'ActiveDocument.Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberRight)
    'ActiveDocument.Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberCenter)
    'ActiveDocument.Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberInside)
    'ActiveDocument.Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberOutside)
    ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleArabic
    'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleArabicFullWidth
    'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleLowercaseLetter
    'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleLowercaseRoman
    'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleNumberInCircle
    'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleNumberInDash
    'ActiveDocument.Sections(1).Footers(1).PageNumbers.NumberStyle = wdPageNumberStyleUppercaseLetter
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.Add (wdAlignPageNumberLeft)
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.Add (wdAlignPageNumberRight)
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.Add (wdAlignPageNumberCenter)
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.Add (wdAlignPageNumberInside)
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.Add (wdAlignPageNumberOutside)
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleArabic
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleArabicFullWidth
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleLowercaseLetter
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleLowercaseRoman
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleNumberInCircle
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleNumberInDash
    'ActiveDocument.Sections(1).Headers(1).PageNumbers.NumberStyle = wdPageNumberStyleUppercaseLetter
    End Sub

    Keep WORDing
    @Kunde
  8. Sub LisääKuva()
    Dim p As Object
    Dim ylä As Double
    Dim vasen As Double
    Dim leveys As Double
    Dim korkeus As Double
    Dim i As Long
    Dim kuva As String

    'muuta SOLU
    Range("A50").Select
    'muuta SOLUALUE
    'Range("A50:D50").Select
    For i = 1 To 2
    'muuta POLKU JA NIMI
    kuva = "E:\BELL" & i & ".jpg"
    Set p = ActiveSheet.Pictures.Insert(kuva)
    With p
    .Top = Selection.Top
    .Left = Selection.Left
    .Width = Selection.Offset(0, Selection.Columns.Count).Left - Selection.Left
    .Height = Selection.Offset(Selection.Rows.Count, 0).Top - Selection.Top
    End With
    Selection.Offset(1, 0).Select
    Next
    Set p = Nothing
    End Sub
  9. moduuliin....
    muuta nimet sopiviksi

    Option Explicit

    Sub Kuvakoe()
    ' solualueelle kuva
    LisääKuva "E:\testi.jpg", Range("A50:D65")
    'yksittäiseen soluun kuva
    'LisääKuva "E:\testi.jpg", Range("A50")
    End Sub

    Sub LisääKuva(Tiedosto As String, Solu As Range)
    Dim p As Object
    Dim ylä As Double
    Dim vasen As Double
    Dim leveys As Double
    Dim korkeus As Double
    Set p = ActiveSheet.Pictures.Insert(Tiedosto)
    With p
    .Top = Solu.Top
    .Left = Solu.Left
    .Width = Solu.Offset(0, Solu.Columns.Count).Left - Solu.Left
    .Height = Solu.Offset(Solu.Rows.Count, 0).Top - Solu.Top
    End With
    Set p = Nothing
    End Sub

    Keep EXCELing
    @Kunde
  10. Sub PuraOsoitteet()
    Dim i As Long
    Dim Postinumero As Integer
    Dim solu As Range
    Dim vika As Long
    vika = Range("C65536").End(xlUp).Row
    For Each solu In Range("C1:C" & vika)
    For i = Len(solu) To 1 Step -1
    If IsNumeric(Mid(solu, i, 1)) Then
    Postinumero = Postinumero + 1
    End If
    If Postinumero = 5 Then
    solu.Offset(0, 1) = Left(solu, i - 1)
    solu.Offset(0, 2).NumberFormat = "@"
    solu.Offset(0, 2) = Mid(solu, i, 5)
    solu.Offset(0, 3) = Mid(solu, i + 6)
    Exit For
    End If
    Next
    Postinumero = 0
    Next
    End Sub
  11. onhan noita mun väsäämiä mallikoodeja useita tällä foorumilla- eli onnistuu melko kivuttomasti. ..
    tarttee vaan tarkemmat tiedot
    mistä kansiosta ja mistä soulista ja mihin soluihin tieto haetaan (summataan)
  12. niinpä...
    et kertonut aluksi, että haluat tulostaa useampia välilehtiä eri nimillä ja hakoteillä olin taas...
    Ei taida onnistua tuo, koska printteri näköjään kuitenkin käyttää tallenna lomaketta tulostaessaan taulukkoa ja kokeilin syöttää siihen sitten tietoja eri tavoilla (osaan kyllä ton) ja virhettä pukkaa aina ja ohjeita ei loe mikä mattää :-(
    Netistä löysin ilmaisen toimivan version sun tapaukseen( ei tartte paljoa fiksata Print Multiple Worksheets to Multiple PDF Files koodia) ja tuntui toimivan ihan jees...

    koodi
    http://www.excelguru.ca/node/21#MultiMulti

    printteri
    http://sourceforge.net/projects/pdfcreator/

    Keep EXCELing
    @Kunde
  13. himassahan sitä ollaan taas!

    tää koodin pätkä pitäisi toimia, eli vaihtaa oletustulostimen PDF-XChangeksi ja tulostaa tiedoston ja sitten palauttaa oletustulostimen takaisin

    Ei ole koneella tota PDF-XChange tulostinohjelmaa, mutta eiköhän sen omimaisuuksista voi suoraan määritellä tarvittavat polut ja oletusnimet....

    eli menusta FILE/PRINT ja avautuvasta valikosta valitset ton PDF-XChange tulostimen ja klikkaa vieressä olevaa PROPERTIES nappia ja sitten vaan kattelet, jospa jossain olisi tallennusasetukset ja rukkaat ne kohilleen...
    polku= C:\liitteet
    nimi=raportti

    moduuliin...

    Dim Oletustulostin As String
    Oletustulostin = Application.ActivePrinter
    Application.ActivePrinter = "PDF-XChange 4.0 on Ne05:"
    ActiveSheet.PrintOut
    Application.ActivePrinter = Oletustulostin
    End Sub


    Keep EXCELing
    @Kunde
  14. suomenkielistä kunnon kirjaa ei ole eikä tule kun kopioidaan vanhaa ja lisätään pari uutta juttua malkliksi vanhaan kirjaan -rahastusta...
    laita email mulle niin kerron mistä saat [email protected]

    tää keskustelupalstan softa on ihan p*tä. Ei edes kooditageja ole saati liitetiedostojen liittämismahdollisuutta ei ole

    kunpa olisi aikaa paneutua omaan foorumiin niin siellä homma toimii...
    katellaan jos aikaa riittäisi sen ylläpitoon, infoan kun alan pyörittämään Excel osiota
  15. todennäköisesti asia on kuten itsekin totesit, eli navigaattorissa homma tehdään. Olen muistaakseni kerran nähnyt tommosen tekstitiedoston ja ei siinä ollut mitää muuta kuin paikkatietoja, eli ilmeisesti samassa kansiossa olevaa kuvaa sitten käytää kordinaattipisteille, joten villi arvaukseni on, että pitää vaan tehdä erilliset kansiot kaikille pankeille
  16. esim. näin

    sarakkeeseen A oma solumuotoilu pp.kk ppp

    solu A1=1.7.2011 (1.7. pe)
    solut A2 ja A3 tyhjiä
    solu A4=2.7.2011 (2.7. pe)
    solut A5 ja A6 tyhjiä
    maalaa alue A1:A6 ja raahaa hiiren vasemmallaalaspäin tarpeellinen määrä
  17. CTRL+TAB
  18. ei oo aikaa enempää kun reissua pukkaa...
    poista kaavat N sarakkeesta ja lisää se koodissa oamakaavasi kohtaan...

    jos ei onnaa niin viikon päästä palailen asiaan

    väri on 15 =harmaa, muuta oikeaksi

    taulukon moduuliin...

    Option Explicit

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B:B")) Is Nothing Then
    If Target.Offset(0, 12).Interior.ColorIndex = 15 Then
    Target.Offset(0, 12) = ""
    Else
    Target.Offset(0, 12).Formula = "omakaavasi tähän"
    End If
    End If
    End Sub

    Keep EXCELing
    @Kunde
  19. haet siis solulla B59 arvoa toisesta taulukosta ja olet varmaankin kopioinut kaavaa alaspäin jolloin seuraavaan soluun haetaan arvoa solusta B60 jne...

    tokassa kaavassa yrität sitten "funktioräpellyksestäsi" päätellen laskea solun N5 värin mukaan joko summaa tai solun N5 väristen lukumäärää soluista N4:N50 riippuen funktion kutsusta?

    päin persettähän toi on kokonaan...
    funktio ei palauta mitään

    jos siis haluat laskea tietyltä alueelta tietynväriset arvot niin paras tehdä oma makro ja käyttää sitä ja samalla tyhjentää tietynväristen solujen arvot.
    Mitenkäs noi värit soluun määritellään?

    kahotaan saatko selkokielistä kyssäri aikaan...
  20. periaaatteessa näin, mutta tietämättä miten suljet normaalisti, mutta helppo fiksata ...

    ThisWorkbook moduuliin...

    Option Explicit
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Range("P2") = Now()
    End Sub

    Keep EXCELing
    @Kunde
    21. 27 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt