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. Excelistä tuo työkalu puuttuu...(voi olla 2010, mutta ei sitä aikaisemmissa versioissa ainakaan ole)

    Koodillakin paska duunata, kun pitäisi tietää muokattava merkki solussa ja se ei ole helppoa. Koko solun muokkaus sensijaan piece of the cake, mutta siitähän nyt ei ollutkaan kyse.
    Toki aktiivisen solun merkit voisi kopioida lomakkeelle ja sitten muokata valittuja merkkejä yksitellen ja lopuksi palauttaa takaisin muokattuna aktiiviseen soluun, mutta työlästä työlästä...
  2. moduuliin...
    muuta hakusolu=K1 ja hakualue= A1:D10 sopiviksi

    Function EtsiiKaikkiAlueelta(Hakuehto As Variant, HakuAlue As Range) As String
    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
    EkaOsoite = solu.Address
    Do
    EtsiiKaikkiAlueelta = EtsiiKaikkiAlueelta & ", " & solu.Address
    Set solu = .FindNext(solu)
    Loop While Not solu Is Nothing And solu.Address EkaOsoite
    End If
    End With
    EtsiiKaikkiAlueelta = Right(EtsiiKaikkiAlueelta, Len(EtsiiKaikkiAlueelta) - 1)
    End Function

    Sub Etsi()
    Dim solut As String
    On Error GoTo virhe
    solut = EtsiiKaikkiAlueelta(Range("K1"), Range("A1:D10"))
    MsgBox Range("K1") & " löytyi solu(i)sta" & solut
    Exit Sub
    virhe:
    MsgBox "ei löytynyt!"
    End Sub

    Keep EXCELing
    @Kunde
  3. onhan siinä paljonkin vikaa...
    ei toi tee muuta kuin tulostaa... eli tietenkin kysyy polkua jne.
    eikä koodisa ole mitään sähkärin lahettämistäkään-ei nauhuri nauhoita noita juttuja...

    vaatii koodaajaa...

    ,-) Kunde
  4. 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)
  5. 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
  6. 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
  7. 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
  8. 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
  9. 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
  10. 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
  11. 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
  12. 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
  13. 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
  14. 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)
  15. 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
  16. 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
  17. 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 kunde@hotmail.fi

    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
  18. 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
  19. 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ä
  20. CTRL+TAB
    21. 27 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt