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. kyseessä ihan perusjuttu ja muutama kaava

    A1=P
    B1=U
    C1=I
    D1=R

    soluihin A2:D2 syötetään 2 arvoa...
    tulos soluihin A3:D3

    en jaksanut tarkistella kaavoja...

    moduuliin...

    Public Function IPR(P As Double, R As Double) As Double
    IPR = Sqr(P / R)
    End Function
    Public Function PUI(U As Double, I As Double) As Double
    PUI = U * I
    End Function
    Public Function PUR(U As Double, R As Double) As Double
    PUR = U * U / R
    End Function
    Public Function PIR(I As Double, R As Double) As Double
    PIR = I * I * R
    End Function

    Public Function UPR(P As Double, R As Double) As Double
    UPR = Sqr(P * R)
    End Function
    Public Function UIR(I As Double, R As Double) As Double
    UIR = I * R
    End Function
    Public Function RUI(U As Double, I As Double) As Double
    RUI = U / I
    End Function
    Public Function RPI(P As Double, I As Double) As Double
    RPI = P / (I * I)
    End Function
    Public Function RPU(P As Double, U As Double) As Double
    RPU = P * U * U
    End Function

    taulukon moduuliin...

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    Application.EnableEvents = False

    If Not Range("A2") = "" And Not Range("D2") = "" Then
    Range("A3:D3") = ""
    Range("C3").Value = IPR(Range("A2"), Range("D2"))
    Range("B3").Value = UPR(Range("A2"), Range("D2"))
    Range("A3") = Range("A2")
    Range("D3") = Range("D2")
    Range("A2:D2") = ""
    End If

    If Not Range("B2") = "" And Not Range("C2") = "" Then
    Range("A3:D3") = ""
    Range("A3").Value = PUI(Range("B2"), Range("C2"))
    Range("D3").Value = RUI(Range("B2"), Range("C2"))
    Range("B3") = Range("B2")
    Range("C3") = Range("C2")
    Range("A2:D2") = ""
    End If

    If Not Range("B2") = "" And Not Range("D2") = "" Then
    Range("A3:D3") = ""
    Range("A3").Value = PUR(Range("B2"), Range("D2"))
    Range("B3") = Range("B2")
    Range("D3") = Range("D2")
    Range("A2:D2") = ""
    End If

    If Not Range("C2") = "" And Not Range("D2") = "" Then
    Range("A3:D3") = ""
    Range("A3").Value = PIR(Range("C2"), Range("D2"))
    Range("B3").Value = UIR(Range("C2"), Range("D2"))
    Range("C3") = Range("C2")
    Range("D3") = Range("D2")
    Range("A2:D2") = ""
    End If

    If Not Range("C2") = "" And Not Range("D2") = "" Then
    Range("A3:D3") = ""
    Range("A3").Value = PIR(Range("C2"), Range("D2"))
    Range("C3") = Range("C2")
    Range("D3") = Range("D2")
    Range("A2:D2") = ""
    End If

    If Not Range("C2") = "" And Not Range("D2") = "" Then
    Range("A3:D3") = ""
    Range("A3").Value = PIR(Range("C2"), Range("D2"))
    Range("C3") = Range("C2")
    Range("D3") = Range("D2")
    Range("A2:D2") = ""
    End If

    If Not Range("A2") = "" And Not Range("D2") = "" Then
    Range("A3:D3") = ""
    Range("B3").Value = UPR(Range("A2"), Range("D2"))
    Range("A3") = Range("A2")
    Range("D3") = Range("D2")
    Range("A2:D2") = ""
    End If



    If Not Range("A2") = "" And Not Range("C2") = "" Then
    Range("A3:D3") = ""
    Range("D3").Value = RPI(Range("A2"), Range("C2"))
    Range("A3") = Range("A2")
    Range("C3") = Range("C2")
    Range("A2:D2") = ""
    End If

    If Not Range("A2") = "" And Not Range("B2") = "" Then
    Range("A3:D3") = ""
    Range("D3").Value = RPU(Range("A2"), Range("B2"))
    Range("A3") = Range("A2")
    Range("B3") = Range("B2")
    Range("A2:D2") = ""
    End If
    If Application.WorksheetFunction.CountA(Range("A2:D2")) = 2 Then
    Range("A3:D3") = ""
    End If
    Application.EnableEvents = True
    End Sub
    Sub Resetoi()
    Application.EnableEvents = True
    End Sub
  2. nyt desimaalitkin mukana ;-)

    Sub koe()
    Dim Lähdealue2 As Range
    Dim vika2 As Integer

    vika2 = Range("D65536").End(xlUp).Row
    Set Lähdealue2 = Range("D5:D" & vika2)
    For Each solu In Lähdealue2
    Select Case solu
    Case Is > 0
    solu.Offset(0, 7) = CDbl(Range("G7")) + CDbl(solu) + CDbl(Range("I1"))
    Case Is < 0
    solu.Offset(0, 7) = CDbl(Range("G7")) - CDbl(solu) - CDbl(Range("I1"))
    Case 0
    solu.Offset(0, 7) = CDbl(Range("G7"))
    End Select
    Next
    End Sub
  3. joo kyllä Kunden portaali aukeaa virallisestikin kevään aikana. Varmuuskopiot serveriltä vaan menivät "vituiksi" ja joudun manuaalisesti tekeen juttuja uusiksi. Portaaliin tulee aluksi osiot CAD/CAM/CNC, EXCEL(myöhemmin muut officejutskat) ja MATKAILU lähinnä nyt THAIMAA (Khorat ja Pattaya). Varsinkin CAD/CAM/CNC osaajat voisivat lähettää mulle mailia [email protected]

    KEEP EXCELING
    Kunde
  4. kyllä se siitä treenaamalla...

    Sub koe()
    Dim Lähdealue2 As Range
    Dim vika2 As Integer

    vika2 = Range("D65536").End(xlUp).Row
    Set Lähdealue2 = Range("D5:D" & vika2)
    For Each solu In Lähdealue2
    Select Case solu
    Case Is > 0
    solu.Offset(0, 7) = Val(Range("G7")) + Val(solu) + Val(Range("I1"))
    Case Is < 0
    solu.Offset(0, 7) = Val(Range("G7")) - Val(solu) - Val(Range("I1"))
    Case 0
    solu.Offset(0, 7) = Val(Range("G7"))
    End Select
    Next
    End Sub
  5. voithan koodilla poistaa suojauksen lajittelun ajaksi ja sitten suojata taulukon taas esim.

    Worksheets("Sheet1").Unprotect Password:="kunde"
    lajittelukoodi tähän
    ...
    Worksheets("Sheet1").Protect Password:="kunde"
  6. ei toimi 97 versiossa. 2000 versiosta lähtien ton pitäs muistaakseni toimia ja uudemmissa versioissahan on noita lukituksen poistoja sitten lisäilty enemmänkin, joten sorry!
  7. siinä missä laitat suojauksen koodissa lisäät vaan seuraavan

    UserInterfaceOnly:=True eli esim.

    Worksheets("Sheet1").Protect Password:="kunde", UserInterfaceOnly:=True

    et tarvitse sitten enää tuota riviäkään... ActiveWorkbook.Worksheets(2).EnableAutoFilter = True
  8. originelli oli näin, ja siinä on toi "Alue", jonka määrittelet valikosta lisää/nimi/määritä Insert/Name/Define ja siinä valitset haluamasi solut ja annat alueelle nimeksi Alue. Näin sen ajattelin...
    Ok voit muuttaa koodia siten, että korvaat
    For Each solu In Range("Alue") tällä
    For Each solu In Range("A2:A6000") ja käyt sitten koodissa muuttamassa aluetta.
    Tietenkin voit tehdä niin, että valinta on alueena, niin ei tartte kuin valita testattavat solut ja suorittaa koodi
    esim.

    Sub PoistaTuplat()
    Dim solu As Range
    Dim Vika As Double
    On Error GoTo virhe
    For Each solu In Selection
    If Not IsEmpty(solu) Then
    EiTupla.Add solu.Value, CStr(solu.Value)
    End If
    Next solu
    Exit Sub
    virhe:
    Resume Next
    End Sub
  9. "Esim. Poistan sieltä kaikki paitsi yhden solun. Kun ajan värjäys_makron uudestaan, niin värjää makro samat solut kuin aikaisemmalla kerralla. Ihan ku makro hakisi tiedot jostain muistista, eikä siltä Sheet2 alueelta."

    nimeä taulukko2 verrattavat solut ="Alue"
    et ole nimennyt haettavia soluja uudelleen.

    "poistan värjäykset kokonaan Sheet1 taulukosta"

    Makrohan poistaa värjäykset automaattisesti Sheet1:stä.Joten ei tartte tehdä...

    eli...
    Nimeä vain ne solut mitä vertaat ="Alue" ja toimii just niinkuin pitääkin...
  10. vähän oli ylimalkainen kyssäri tiedoilta, mutta tolla alkuun
    moduuliin...

    nimeä taulukko2 verrattavat solut ="Alue" ja muokkaa taulukoiden nimet sopiviksi

    Option Explicit
    Dim EiTupla As New Collection

    Sub Värjää()
    Dim Tiedot As Variant
    Dim Alue As Range
    Dim i As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Worksheets("Sheet2").Activate
    PoistaTuplat
    Worksheets("Sheet1").Cells.Interior.ColorIndex = xlNone
    For i = 1 To EiTupla.Count
    Set Alue = EtsiJaSiirrä(EiTupla(i), Worksheets("Sheet1").Cells)
    Alue.Interior.ColorIndex = 3
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub

    Sub PoistaTuplat()
    Dim solu As Range
    Dim Vika As Double
    On Error GoTo virhe
    For Each solu In Range("Alue")
    If Not IsEmpty(solu) Then
    EiTupla.Add solu.Value, CStr(solu.Value)
    End If
    Next solu
    Exit Sub
    virhe:
    Resume Next
    End Sub

    Function EtsiJaSiirrä(Haettava As Variant, _
    Hakualue As Range) As Range

    Dim solu As Range
    Dim ekaosoite As String

    With Hakualue
    Set solu = .Find( _
    What:=Haettava, _
    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
  11. haluamasi taulukon moduuliin...
    muuta Arrayssa olevien taulukoiden nimiä sopiviksi

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Sheets(Array "Sheet1", "Sheet2", "Sheet3")).Select
    End Sub
  12. moduuliin...
    muuttele taulukoiden nimet sopiviksi

    Option Explicit
    Dim EiTupla As New Collection
    Sub Kopioi()
    Dim Tiedot As Variant
    Dim Alue As Range
    Dim i As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Worksheets("Sheet1").Activate
    Worksheets("Sheet2").Cells.Clear
    PoistaTuplat
    For i = 1 To EiTupla.Count
    Set Alue = EtsiJaSiirrä(EiTupla(i), Columns("A")).Offset(0, 1)
    Tiedot = Alue
    Tiedot = Application.WorksheetFunction.Transpose(Tiedot)
    Range("Sheet2!A" & i) = EiTupla(i)
    Range("Sheet2!B" & i).Resize(Alue.Columns.Count, Alue.Rows.Count) = Tiedot
    Next i
    Worksheets("Sheet2").Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub
    Sub PoistaTuplat()
    Dim solu As Range
    Dim Vika As Double
    On Error GoTo virhe
    Vika = Range("A65536").End(xlUp).Row
    For Each solu In Range("A1:A" & Vika)
    If Not IsEmpty(solu) Then
    EiTupla.Add solu.Value, CStr(solu.Value)
    End If
    Next solu
    Exit Sub
    virhe:
    Resume Next
    End Sub
    Function EtsiJaSiirrä(Haettava As Variant, _
    Hakualue As Range) As Range

    Dim solu As Range
    Dim ekaosoite As String

    With Hakualue
    Set solu = .Find( _
    What:=Haettava, _
    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
  13. kysyttiin...
    "siirtää tiedot seuraavalla sheetillä olevaan taulukkoon ensimmäiselle riville (siirtäen aiempia rivejä vastaavasti alaspäin)"

    vastasit
    yksinkertainen niin mikset käytä XL:n valmista Data->form toimintoa

    mitenkäs tolla siirrät seuraavalle sivulle ja siirrät tiedon aina ekalle riville ja päivität muita alaspäin???
    Kerro meille kuinka se tapahtuu ehdottamallasi valmiilla toiminnolla, kun en saa sitä toiminaan kysymyksessä esitetyllä tavalla...

    Makro= piece of cake
  14. soluun kaavana esim. =Palkka(A1)

    moduuliin...

    Public Function Palkka(Palkkaluokka As Integer) As Integer
    Select Case Palkkaluokka
    Case 1
    Palkka = 9
    Case 2
    Palkka = 10
    Case 3
    Palkka = 11
    Case 4
    Palkka = 12
    Case 5
    Palkka = 13
    Case Else
    Palkka = 0
    End Select
    End Function
  15. Sub UusiVuosi()
    Range("A1")=2009
    End Sub

    ;-)
    uusi vuosi ja uudet kujeet
    jälleen grillataan (nyt aamulla +22 C (klo 7), joten kaiketi tarkenen...)
    Keep Exceling
    @Kunde
  16. =INDIRECT("A"&ROW())*2
  17. muuta kaavat
    =INDIRECT("A1")*2 tai lontoon kielelllä
    =EPÄSUORA("A1")*2 jne...
  18. ThisWorkbook moduuliin...

    Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    ActiveWorkbook.SaveAs "C:/sdtilaus" & Range("A1") & ".xls"
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Cancel = True
    End Sub
  19. moduuliin...

    Sub MuutaLuvuksi()
    With Range("B6:AA100")
    .NumberFormat = 0
    .Value = .Value
    End With
    End Sub
  20. nyt lähes normaali toiminnat...
    leikkaa heti kun valitaan solu...
    paste special ei toimi tietenkään...

    katotaan saako paremmaksi vielä

    viittaus Microsoft Forms 2.0 Object Libraryyn

    ThiWorkbook moduuliin...

    Option Explicit
    Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
    Static Vanha As Range
    Static kopiointi As Integer
    On Error Resume Next
    kopiointi = Application.CutCopyMode
    If Not Vanha Is Nothing Then
    Vanha.EntireRow.Interior.ColorIndex = xlColorIndexNone
    End If
    Target.EntireRow.Interior.ColorIndex = 15
    If kopiointi = 1 Then
    Leikepöytä (AlueLeikepöytä(Vanha))
    End If
    If kopiointi = 2 Then
    Leikepöytä (AlueLeikepöytä(Vanha))
    Vanha = ""
    End If
    Set Vanha = Target
    End Sub

    tavalliseen moduuliin...
    Option Explicit
    Option Compare Text
    Private DataObj As MSForms.DataObject
    Public Function Leikepöytä(S As String)
    On Error GoTo virhe:
    If DataObj Is Nothing Then
    Set DataObj = New MSForms.DataObject
    End If
    DataObj.SetText S
    DataObj.PutInClipboard
    Exit Function
    virhe:
    Exit Function
    End Function
    Public Function AlueLeikepöytä(Alue As Range) As String

    Dim Rivi As Long
    Dim Sarake As Long
    Dim Teksti As String
    For Rivi = 1 To Alue.Rows.Count
    For Sarake = 1 To Alue.Columns.Count
    Teksti = Teksti & Alue(Rivi, Sarake).Value & _
    IIf(Sarake < Alue.Columns.Count, vbTab, vbNullString)
    Next Sarake
    Teksti = Teksti & IIf(Rivi < Alue.Rows.Count, vbNewLine, vbNullString)
    Next Rivi
    AlueLeikepöytä = Teksti
    End Function
    21. 55 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt