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. poista ensiksi taulukosta (nyt Sheet1) kaikkien solujen lukitus ja suojaa VBA projekti salasanalla. Tallenna sitten työkirja normaalisti ja siinäpä se...

    oletuksena, että A sarakkeeseen tulee aina tieto, muuta sopivaksi

    ThisWorkbook moduuliin...

    Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim vika As Integer
    On Error Resume Next
    Sheets("Sheet1").Unprotect Password:="Kunde"
    vika = Range("A65536").End(xlUp).Row
    Range("A1:A" & vika).EntireRow.Locked = True
    Sheets("Sheet1").Protect Password:="Kunde"
    End Sub
  2. ei voi tehdä pelkillä kaavoilla, joten on käytettävä koodia...
    koodi toimii siten, että kun taulukko1:ssä joku tieto muuttuu tarkistetaan löytyykö TRUE. Jos löytyi piilotetaan sarakkeet, muuten poistetaan piilotus.
    pikkumuutoksilla voi esim. tyhjentää solujen arvot
  3. muuttele alueita sopivaksi

    taulukon moduuliin

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    HaeJaPiilota
    End Sub

    moduuliin...

    Function HaeJaPiilota()
    Dim solu As Range
    With Sheets("Sheet1").Cells
    Set solu = .Find( _
    What:=True, _
    LookIn:=xlValues, _
    LookAt:=xlWhole, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, _
    MatchCase:=False, _
    SearchFormat:=False)
    End With


    If Not solu Is Nothing Then
    Sheets("Sheet2").Columns("F:G").EntireColumn.Hidden = True
    Else
    Sheets("Sheet2").Columns("F:G").EntireColumn.Hidden = False
    End If

    End Function
  4. 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
  5. 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
  6. 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 kundepuu@hotmail.com

    KEEP EXCELING
    Kunde
  7. 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
  8. 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"
  9. 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!
  10. 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
  11. 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
  12. "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...
  13. 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
  14. 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
  15. 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
  16. 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
  17. 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
  18. 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
  19. =INDIRECT("A"&ROW())*2
  20. muuta kaavat
    =INDIRECT("A1")*2 tai lontoon kielelllä
    =EPÄSUORA("A1")*2 jne...
    21. 55 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt