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. no problems...
    palaan ensiviikolla asiaan kun taas normaali enkkuversio kaytossa
  2. Ei oikein taivu taa Kiinan kieli naissa koneissa taalla Kiinassa...
    palaan ensiviikolla asiaan jos viela silloinn tarvetta
  3. hae, haejasiirra, etsi etsijasiirra yms... a pilkut puuttuu kun ei skandeja tassa internetkoneessa ja en muista ulkoa niita...
    kirjoittajana kunde
    ja kymmenia vastauksia vastaaviin kyssareihin loytyy...
  4. jos tulostuksessa haluat eri muotoilut eri sivulle niin koodaamalla ihan helposti
    esim. Workbook_BeforePrint(Cancel As Boolean) tapahtumaan...
  5. viestissäni lukee erikseen moduulien paikat
    taulukon moduuliin...
    ja moduuliin...
    eli alla oleva tavalliseen moduuliin, EI taulukon moduuliin ja taatusti pelittäää

    moduuliin...

    Sub Täytä()
    On Error Resume Next
    Application.ScreenUpdating = False
    Range("Sheet2!D20:D44 ") = ""
    Range("Sheet2!I20:I44 ") = ""
    Range("Sheet2!J20:J44 ") = ""
    Range("A18").Copy
    Sheets("Sheet2").Range("D20").PasteSpecial Paste:=xlPasteValues
    Range("C18").Copy
    Sheets("Sheet2").Range("I20").PasteSpecial Paste:=xlPasteValues
    Range("E18").Copy
    Sheets("Sheet2").Range("J20").PasteSpecial Paste:=xlPasteValues

    Sheets("Sheet2").Range("D20").AutoFill Destination:=Range("Sheet2!D20:D" & 19 + Range("B18")), Type:=xlFillDefault
    Sheets("Sheet2").Range("I20").AutoFill Destination:=Range("Sheet2!I20:I" & 19 + Range("B18")), Type:=xlFillDefault
    Sheets("Sheet2").Range("J20").AutoFill Destination:=Range("Sheet2!J20:J" & 19 + Range("B18")), Type:=xlFillDefault
    Application.ScreenUpdating = True
    End Sub
  6. vaihda taulukon nimi sopivaksi nyt "Sheet2"
    taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Application.Intersect(Target, Range("B18")) Is Nothing Then
    Täytä
    End If
    End Sub

    moduuliin...

    Sub Täytä()
    On Error Resume Next
    Application.ScreenUpdating = False
    Range("Sheet2!D20:D44 ") = ""
    Range("Sheet2!I20:I44 ") = ""
    Range("Sheet2!J20:J44 ") = ""
    Range("A18").Copy
    Sheets("Sheet2").Range("D20").PasteSpecial Paste:=xlPasteValues
    Range("C18").Copy
    Sheets("Sheet2").Range("I20").PasteSpecial Paste:=xlPasteValues
    Range("E18").Copy
    Sheets("Sheet2").Range("J20").PasteSpecial Paste:=xlPasteValues

    Sheets("Sheet2").Range("D20").AutoFill Destination:=Range("Sheet2!D20:D" & 19 + Range("B18")), Type:=xlFillDefault
    Sheets("Sheet2").Range("I20").AutoFill Destination:=Range("Sheet2!I20:I" & 19 + Range("B18")), Type:=xlFillDefault
    Sheets("Sheet2").Range("J20").AutoFill Destination:=Range("Sheet2!J20:J" & 19 + Range("B18")), Type:=xlFillDefault
    Application.ScreenUpdating = True
    End Sub
  7. en nyt parempaa vaihtoehtoa keksinyt...

    oletuksena nyt, että A- sarakkeessa on tietoa ja siitä haetaan se vika rivi. Muuta koodissa sarake sopivaksi.
    Toimii siten, että kun taulukossa joku arvo muuttuu vika rivi tulee tokassa paneelissa ylimmäiseksi. Voi scrollata normaalisti ja tehdä juttuja ihan normaalisti, mutta solun arvon muutoksesta pomppaa vikalle riville.
    Tarvittaessa muuta vika muuttujan arvoa jos haluat enemmän rivejä näkyviin ennen summariviä...
    esim. 5 riviä
    ActiveWindow.Panes(1).ScrollColumn = Range("A" & Vika-5).Column
    ActiveWindow.Panes(1).ScrollRow = Range("A" & Vika-5).Row

    1. Valitse rivi 2
    2. Valitse valikosta WINDOW/FREEZE PANES
    3. Kopioi makro taulukon moduuliin...


    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Vika As Double
    Vika = Range("A65536").End(xlUp).Row
    ActiveWindow.Panes(1).ScrollColumn = Range("A" & Vika).Column
    ActiveWindow.Panes(1).ScrollRow = Range("A" & Vika).Row
    End Sub

    Keep Excelling
    @Kunde
  8. en edes ajttelesi koko hommaa. Tosi työlästä ja virheiden mahdollisuus kasvaa.
  9. Kyllä lajittelu toimii varmasti missä tahansa taulukossa. Ei tietoja tartte mihinkään toiseen tiedostoon siirrellä. Tosin makronauhottimella ei nyt kunnon koodia saakaan aikaiseksi...
    Pikkutrreeniä ja kyllä se siitä ;-)

    Keep Excelling
    Kunde
  10. lähestymistapa ;-)
    HYVÄ!
  11. http://www.contextures.com/xlDataVal02.html
  12. A1=lähtöaika
    A2=tuloaika

    soluun kaava =IF(INT(A2-A1)>0;INT(A2-A1)+IF(A2-A1-INT(A2-A1)>0,25;1;IF(A2-A1-INT(A2-A1)>2/24;0,5;0));IF(A2-A1-INT(A2-A1)>10/24;1;IF(A2-A1-INT(A2-A1)>6/24;0,5;0)))

    =B2 OR NOT B2
    @Kunde
  13. vaan argumenttejen syötöstähän tässä on kyse....
    ei toi onnaa ilman VBA: n apua automaattisesti

    soluun kaava =Keskihajonta(A2:A8;2), missä A2:A8 on asteikko ja offset 2 asteikosta eli C -sarakkeessa vastausten määrät.

    moduuliin...

    Option Base 1
    Function Keskihajonta(Arvot As Range) As Double
    Dim i As Long
    Dim j As Long
    Dim solu As Range
    Dim Arr() As Variant

    On Error Resume Next
    Application.Volatile
    j = 1
    For Each solu In Arvot
    ' määrät C sarakkeessa(Offset(0, 2)) kun kaavana =Keskihajonta(A2:A8;2)

    For i = 1 To solu.Offset(0, 2)
    ReDim Preserve Arr(j)
    Arr(j) = solu
    j = j + 1
    Next i
    Next solu
    Keskihajonta = Application.WorksheetFunction.StDev(Arr)
    End Function
  14. klikkaa hiiren oikealla jonkun valikon tai työkalupalkin päällä ja valitse avautuvasta valikosta Customize (Mukauta ?), sitten vain valitset normaalisti muokattavan napin ja klikkaat sitä hiiren oikealla ja avautuvasta valikosta Asssign Macro (Liitä Makro ?) jne...
  15. lpmaketyökaluista tehdylle combolle ominaisuudeksi ListFillRange esim. A1:B100 (tuote ja sen kerroin) ja alla oleva ko. taulukon moduuliin...
    muuta solua mihin kertoimen haluat (nyt K1)

    Private Sub ComboBox1_Change()
    Range("K1") = ComboBox1.Column(1)
    End Sub
  16. poista kaikista lisäosista ruksit ja lisää nyt käytössä olevia yksitellen ja katso mikä aiheuttaa ton virheen. Asenna se lisäosa sitten uudelleen.
    Todennäköisesti 2007 jäi jotakin "paskaa", mikä aiheuttaa versio yhteensopimattomuuden.
  17. korvaa aikaisempi koodi tällä ja näyttää kaappien nimet 1. riviltä
    taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tulos As String
    Dim a As Variant
    Dim Kaapit As String
    On Error Resume Next
    If Not Intersect(Target, Range("K1")) Is Nothing Then
    tulos = EtsiJaNäytä(Range("K1"), Range("A:I")).Address
    If tulos = "" Then
    MsgBox "ei löytynyt!"
    Else
    a = Split(tulos, ",")
    For i = 0 To UBound(a)
    Kaapit = Kaapit & Range(Mid(a(i), 2, 1) & 1) & vbNewLine
    Next
    MsgBox Kaapit
    End If
    End If
    End Sub
  18. firmalaskuri soluista A19
    haluamaasi soluun kaava
    =Yritys("ky")

    missä ky on firmatyyppi (KY,Ky.kY,ky- käy kaikki kirjoitusasut...)
    muuta yhteenveto taulukon nimeä tarvittaessa, nyt yhteenveto ( muuttaa sen pieneksi joten ei ole väliä onko isoja tai pieniä kirjaimia)

    summalaskuri soluista B25
    haluamaasi soluun kaava
    =YritysSumma("ky")

    missä ky on firmatyyppi (KY,Ky.kY,ky- käy kaikki kirjoitusasut...)
    muuta yhteenveto taulukon nimeä tarvittaessa, nyt yhteenveto ( muuttaa sen pieneksi joten ei ole väliä onko isoja tai pieniä kirjaimia)

    moduuliin funktiot

    Option Explicit
    Function Yritys(Firmatyyppi As String) As Long
    Dim taulukko As Worksheet
    Dim löytyi As Variant

    On Error Resume Next
    Application.Volatile
    For Each taulukko In ActiveWorkbook.Worksheets
    If Not LCase(taulukko.Name) = "yhteenveto" Then
    Select Case LCase(taulukko.Range("A19"))
    Case LCase(Firmatyyppi)
    Yritys = Yritys + 1
    Case Else
    End Select
    End If
    Next taulukko
    End Function

    Function YritysSumma(Firmatyyppi As String) As Double
    Dim taulukko As Worksheet
    Dim löytyi As Variant

    On Error Resume Next
    Application.Volatile
    For Each taulukko In ActiveWorkbook.Worksheets
    If Not LCase(taulukko.Name) = "yhteenveto" Then
    Select Case LCase(taulukko.Range("A19"))
    Case LCase(Firmatyyppi)
    YritysSumma = YritysSumma + taulukko.Range("B25")
    Case Else
    End Select
    End If
    Next taulukko
    End Function

    Keep Excelling
    @Kunde
  19. pikkasen hakua peliin foorumilla ja kymmenkunta samantapaista casea ja mun vastaukset niihin löytyy...

    muutaman rivin muokkauksella
    taukoiden nimet nyt pohja ja valmiit ja haetaan A sarakkeesta vastineita

    moduuliin...
    Sub Siirrä()
    Dim Löydetty As Range
    Dim Solu As Range
    Dim vika As Long

    On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets("valmiit").Activate
    vika = Range("A65536").End(xlUp).Row
    For Each Solu In Range("A1:A" & vika)
    Solu.Offset(0, 4) = EtsiJaSiirrä(Solu, Range("pohja!A:A"))
    Next Solu
    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.Offset(0, 3)
    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
  20. taulukon moduuliin...
    nyt hakee solun K1 arvoja sarakkeista A-I ja ilmoittaa solun osoitteen, jos haluat että palauttaa sen ekan rivin kaapin nimen niin muutellaan sitten

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tulos As String
    On Error Resume Next
    If Not Intersect(Target, Range("K1")) Is Nothing Then
    tulos = EtsiJaNäytä(Range("K1"), Range("A:I")).Address
    If tulos = "" Then
    MsgBox "ei löytynyt!"
    Else
    MsgBox tulos
    End If
    End If
    End Sub

    ja moduuliin...

    Function EtsiJaNäytä(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 EtsiJaNäytä = solu
    EkaOsoite = solu.Address
    Do
    Set EtsiJaNäytä = Union(EtsiJaNäytä, solu)
    Set solu = .FindNext(solu)
    Loop While Not solu Is Nothing And solu.Address EkaOsoite
    End If
    End With
    End Function
    21. 47 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt