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. kaikille kerron,jotka mailaavat
  2. mailaa mulle

    [email protected]

    niin kerron paikan mistä ladata...
  3. Tallenna taulukko HTML muodossa ja Excel tekee automaattisesti kaavioista .GIF

    Toinen tapa
    VBA:lla pari rivia koodia...
  4. ja liitä tänne semmoinen toimiva versio tosta suojauksesta. Suojauksien säätely on muuttunut vuosien varrella aika paljon ja työni(asiakkaani)johdosta minulla ei ole uudempaa 2007 versiota käytössäni.
  5. VBA editorin puolella valitse valikoista
    Tools/VBAProject Properties -avautuu lomake ja siitä klikkaa Protection välilehti ja täppä kohtaa Lock Project for viewing ja salasanan kirjoitat pariin kertaa ja OK. Tallenna työkirja ja avaa uudelleen nyt koodit näkyvät vain salasanalla.

    Muutin koodin solunmuutos tapahtumaan...
    koodissa salasana on oltava sama kuin taulukon suojaus salasana.

    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Not Intersect(Target, Range("A1")) Is Nothing Then
    With ActiveSheet
    .Unprotect Password:="Kunde"
    If Range("A1") = 1 Then
    Target.Locked = True

    Else
    MsgBox " Anna solun arvoksi 1"
    Range("A1").Select
    End If
    .Protect Password:="Kunde"
    End With
    End If
    End Sub
  6. tapa 1
    taulukkovalitsimesta klikkaa haluttu taulukko ja hiiren oikealla klikkaat ko taulukon valitsimmessa ja avautuvasta valikosta View Code/Näytä koodi. Avautuvaan moduuliin sitten liität koodin...

    tapa 2
    taulukkopuolella näppäinyhdistelmä CTRL+F11 ja vasemmalta Projektinhallinnasta tuplaklikkaat haluamaasi taulukkomoduulia.
    Varmista, että on oikea projekti laajennettuna (- merkki projektin edessä), jos siinä on + -merkki niin laajenna projekti klikkaamalla + merkkiä. Seuraavaksi pitäisi Microsoft Excel Objects olla näkyvissä ja jos ei ole niin toista ylläoleva. Nyt sieltä löytyy taulukkomoduulit tyyliin Sheet1 (Koe), missä eka on VBA koodissa käytettävä nimi, joka voidaan vaihtaa ominaisuuksista ja suluissa on taulukon nimi, joka näkyy taulukkovalitsimessa.
    No nyt tuplaklikkaat sitten haluamaasi taulukkoa ja liität koodin sinne.
    Kyllä koodin nyt pitäisi toimia...
  7. olet laittanut koodin tavalliseen moduuliin, kun se pitää olla sen taulukon moduulissa, missä haluat lukutksen tapahtuban. Siis TAULUKON MODUULIIN...
  8. oikea koodi
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    If Not Intersect(Target, Range("A1")) Is Nothing Then
    With ActiveSheet
    .Unprotect Password:="Kunde"
    If Range("A1") = 1 Then
    Target.Locked = True
    .Protect Password:="Kunde"
    Else
    MsgBox " Anna solun arvoksi 1"
    Range("A1").Select
    End If
    End With
    End If
    End Sub
  9. taulukon moduuliin..
    poista lukitus taulukon soluista ja muuta solun nimi, salasana ja haluttu arvo sopivaksi

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    If Not Intersect(Target, Range("A1")) Is Nothing Then
    With ActiveSheet
    .Unprotect Password:="Kunde"
    If Range("A1") = 1 Then
    Target.Locked = True
    Else
    MsgBox " Anna solun arvoksi 1"
    End If
    .Protect Password:="Kunde"
    End With
    End If
    End Sub
  10. moduuliin...
    liitä koodi nappiin
    muuta taulukoiden nimet sopiviksi

    Public Sub EtsiErot()
    Dim solu As Range
    On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets("Sheet3").Cells.Clear
    For Each solu In Worksheets("Sheet1").UsedRange
    If Not solu = Worksheets("Sheet2").Cells(solu.Row, solu.Column) Then
    Worksheets("Sheet3").Cells(solu.Row, solu.Column) = "virhe"
    End If
    Next
    For Each solu In Worksheets("Sheet2").UsedRange
    If Not solu = Worksheets("Sheet1").Cells(solu.Row, solu.Column) Then
    Worksheets("Sheet3").Cells(solu.Row, solu.Column) = "virhe"
    End If
    Next
    Worksheets("Sheet3").Activate
    Range("A1").Select
    Application.ScreenUpdating = True
    End Sub
  11. moduuliin...
    muuta nimi sopivaksi

    Sub Auto_Open()
    Worksheets("Taul1"). Activate
    End Sub
  12. moduuliin...

    Sub SuodataJaTeeKaavio()
    Dim dAlku As Date
    Dim dLoppu As Date
    Dim lAlku As Long
    Dim lLoppu As Long
    Dim Näytä As String
    Dim vika As Integer
    Dim kaavio As ChartObject
    Dim Kaaviot As ChartObjects
    On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets("Sheet2").Activate
    For Each kaavio In ActiveSheet.ChartObjects
    kaavio.Select
    kaavio.Delete
    Next
    Columns("A:B").Clear
    Näytä = Range("F1")
    If IsDate(Range("D1")) Then
    dAlku = Range("D1")
    dAlku = DateSerial(Year(dAlku), Month(dAlku), Day(dAlku))
    lAlku = dAlku
    End If
    If IsDate(Range("E1")) Then
    dLoppu = Range("E1")
    dLoppu = DateSerial(Year(dLoppu), Month(dLoppu), Day(dLoppu))
    lLoppu = dLoppu
    End If
    Worksheets("Sheet1").Activate
    With Sheet1
    .AutoFilterMode = False
    .Range("A:D").AutoFilter
    .Range("A:D").AutoFilter Field:=1, Criteria1:=">=" & lAlku, Operator:=xlAnd, Criteria2:="
  13. moduuliin...
    ja liitä koodi nappiin

    muuttele nimet sopiviksi ja nauhoita makro , jolla saat oikean kaaviotyypin...
    nyt
    sheet2 solut D(alkupvm),E(loppupvm),F(mikä sarake näytetään) syöttösoluina ja tiedot sheet1 sarakkeet A-D
  14. moduuliin...
    ja muuttele taulukoiden nimet sopiviksi

    Option Explicit

    Sub Siirrä()
    Dim Alue As Range
    Dim Kotikunta As Range
    Dim Solu As Range
    Dim haku As Variant
    Dim vika As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets("Sheet2").Activate
    vika = Range("A65536").End(xlUp).Row
    For Each Solu In Range("A2:A" & vika)
    Set Alue = EtsiJaSiirrä(Solu, Range("Sheet1!A:A")).EntireRow
    Set Kotikunta = EtsiJaSiirrä(Solu.Offset(0, 1), Alue)
    If Not Kotikunta Is Nothing Then
    Solu.Offset(0, 2) = 1
    Else
    Solu.Offset(0, 2) = 0
    End If
    Next
    Application.ScreenUpdating = True
    End Sub


    Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range
    Dim Solu As Range
    Dim EkaOsoite As String

    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
    Worksheets("Sheet2").Activate
    End Function
  15. taulukko2 moduuliin napille koodi

    Private Sub CommandButton1_Click()
    Siirrä
    End Sub

    moduuliin...
    Option Explicit

    Sub Siirrä()
    Dim Löydetty As Range
    Dim haku As Date
    On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets("Sheet2").Activate
    Range("A3:A1000").EntireRow.Clear
    haku = CDate(Range("A1"))
    Set Löydetty = EtsiJaSiirrä(haku, Range("Sheet1!A:A")).EntireRow
    Union(Löydetty, Löydetty).Copy Range("Sheet2!A3")
    Range("A1").Select
    Application.ScreenUpdating = True
    End Sub


    Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range
    Dim solu As Range
    Dim EkaOsoite As String

    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
    Worksheets("Sheet2").Activate
    End Function

    muuttele nimet sopiviksi
  16. kuten Yucca mainitsi niin automaattinen tekstin korjaus

    http://office.microsoft.com/fi-fi/word/CH060831681035.aspx
  17. olen käyttänyt vastaavaa ohjelmoinnissa. Helppoa laittaa ryhmittäin($) sanomat(lauseet) ja helppo hakea tiedostosta. Tietenkin sen voi tehdä pyytämälläsi tavalla, mutta mielestäni tämä on mukavin ja selkein tapa.

    tee tiedosto C:\lauseet.txt" muotoon

    $10 'aihe1
    kunde testaa1
    kunde testaa2
    kunde testaa3
    $20 'aihe2
    kunde testaa11
    kunde testaa21
    $30 'aihe3
    kunde testaa111
    kunde testaa211
    kunde testaa311
    kunde testaa411
    kunde testaa511

    ja liitä koodi ThisDocument moduuliin...

    kysyy aiheen numeron esim. 20 ja sitten rivinumeron esim. 2 ja kirjoittaa aktiiviseen kohtaan tekstin "kunde testaa21"

    Dim Aihe As Variant
    On Error Resume Next
    Aihe = InputBox("Anna aiheen numero")
    If Aihe = "" Then Exit Sub
    Tekstirivi = InputBox("Anna rivinumero")
    If Tekstirivi = "" Then Exit Sub
    Selection.TypeText LueTeksti("C:\lauseet.txt", Aihe, Tekstirivi)
    End Sub
    Function LueTeksti(strTextFile As String, strDollari As Variant, lngTxtLine As Variant) As Variant

    Dim dollari As String
    Dim Tekstirivi As String
    Dim Rivinumero As Long
    Dim Dollaritesti As Boolean
    Dim Pituus As Long
    Dim Tarkistus As Long
    Dim Oma As Long


    On Error GoTo VIRHE
    dollari = "*$" & strDollari & "*"
    Open strTextFile For Input As #1

    Do While Not EOF(1)
    Line Input #1, Tekstirivi
    If Tekstirivi Like dollari Then
    Dollaritesti = True
    Rivinumero = 0
    End If

    If Dollaritesti = True Then
    If Rivinumero = lngTxtLine Then
    Oma = InStr(1, Tekstirivi, (Chr(39)))
    If Oma > 0 Then
    Pituus = Len(Tekstirivi)
    Tarkistus = InStr(1, Tekstirivi, (Chr(39)))
    If Tarkistus > 0 Then
    LueTeksti = Mid(Tekstirivi, 1, (Tarkistus - 2))
    If LueTeksti = "False" Or LueTeksti = "True" Then
    LueTeksti = CBool(LueTeksti)
    Exit Do
    ElseIf IsNumeric(LueTeksti) = True Then
    LueTeksti = CDbl(LueTeksti)
    Exit Do
    Else
    LueTeksti = CStr(LueTeksti)
    Exit Do
    End If
    End If
    ElseIf Oma = 0 Then
    LueTeksti = Tekstirivi
    If LueTeksti = "False" Or LueTeksti = "True" Then
    LueTeksti = CBool(LueTeksti)
    Exit Do
    ElseIf IsNumeric(LueTeksti) = True Then
    LueTeksti = CDbl(LueTeksti)
    Exit Do
    Else
    LueTeksti = CStr(LueTeksti)
    Exit Do
    End If
    End If
    End If
    Rivinumero = Rivinumero + 1
    End If
    Loop
    Close #1
    POISTU:
    If LueTeksti = Empty Then MsgBox "Annettua riviä ei löydy!!!", vbCritical
    Exit Function
    VIRHE:
    Close #1
    MsgBox "Joku meni pieleen!!!", vbCritical
    Resume POISTU
    End Function


    Keep Excelling (Wording)
    @Kunde

    P.S. seuraavaksi varmaan haluatkin tiedot lomakkeelle, josta klikkaamalla sitten suoraan tekstiin... :-)
  18. Sheets("data").Range("J105").End(xlDown)
    etsitään viimeinen tietoa sisältävä solu solusta J105 alaspäin
    .Offset(1, 0) taas valitsee yhden solun alaspäin aktiivisesta solusta
    eli

    Sheets("data").Range("J105").End(xlDown).Offset(1, 0)

    valitsee aina ensimmäisen tyhjän solun solusta J105 alaspäin

    voit poistaa ja lisätä rivejä ihan vapaasti ja tuo ylläoleva koodi pitää huolen oikeasta ekasta tyhjästä solusta...

    nyt mennään alaspäin ja jos välissä on tyhjä solu tyssää siihen eli pitää olla yhtenäinen alue tota käytettäessä.
    Jos välissä saa olla tyhjiä rivejä ja silti haluat aina viimeisen tyhjän solun sarakkeessa niin koodia pitää muuttaa
    Sheets("data").Range("J65536").End(xlUp).Offset(1, 0)
  19. tekstiruudun tiedot menee tekstinä soluun. Kyllähän se sorttaus pitäisi silti onnistua...
    kokeile laittaa siirrossa pvm muutos seuraavasti
    esim.
    Sub Koe()
    Dim vika As Integer
    On Error Resume Next
    Sheets(1).Activate
    vika = Range("A65536").End(xlUp).Row + 1
    Range("A" & vika) = CDate(TextBox1)
    Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    End Sub

    P.S. käytä mun postaamaa HaeJASiirrä funktiota , se on kätevä tossa tapauksessa...
  20. soluun C1=1
    soluun C2 allaoleva matriisikaava ja vetämällä alaspäin

    {=IF(A2="";"";SUMPRODUCT(IF((A2
    21. 53 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt