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. tee nappi ja liitä allaoleva koodi siihen. Värjää aktiivisesta solusta(oikealleja alas) korkeus*leveys kokoisen alueen keltaiseksi. Muuta vakioita ja värikoodia(kelt.=6)

    moduuliin...

    Const Korkeus As Integer = 6
    Const Leveys As Integer = 10
    Sub Maalaa()
    ActiveCell.Resize(Korkeus, Leveys).Interior.ColorIndex = 6
    End Sub
  2. makron pitää toimia alhaalta ylöspäin... ;-)
  3. käytä solun omaa muotoilua ja lisää sinne puuttuvat värit ja niille tarvittavat rajaehdot.
    Tietenkin VBA:lla sitten saat vaihtoehtoja riittävästi
  4. kopsaamalla sen osan vaikkapa uudelle layerille eri paikkaan ja koodaamalla hiukan niin pitäs ton onnistua ihan hyvin...
  5. If unsaved workbooks are open when you use this method, Microsoft Excel displays a dialog box asking whether you want to save the changes. You can prevent this by saving all workbooks before using the Quit method or by setting the DisplayAlerts property to False. When this property is False, Microsoft Excel doesn’t display the dialog box when you quit with unsaved workbooks; it quits without saving them.

    If you set the Saved property for a workbook to True without saving the workbook to the disk, Microsoft Excel will quit without asking you to save the workbook.

    joten kyllä allaoleva pitäisi toimia (toimii ainakin mulla)

    Sub Sulje()
    Application.DisplayAlerts = False
    Application.Quit
    End Sub

    suljetaan kaikki muut työkirjat yksitellen tallentamatta niitä (tai jos tarttee tallentaa niin muuta Työkirja.Close False---> Työkirja.Close True)-paitsi yksi (1 pitää olla aina auki..) eli jätetään yksi sulkematta ja sitten suljetaan se lopuksi.
    Nyt ei ainakaan pitäisi herjoja tulla...


    Sub Sulje2()
    Dim Työkirja As Workbook
    Application.DisplayAlerts = False

    For Each Työkirja In Application.Workbooks
    If Työkirja.Name "suljevikana.xls" Then ' muuta tähän aukijäävän työkirjan nimi
    Työkirja.Close False
    End If
    Next

    Application.Quit
    End Sub

    ohjeen mukaisesti...
    kerrotaan Excelille , että ollaankin tallennettu työkirjat... ;-)

    Sub Sulje3()
    Dim Työkirja As Workbook
    For Each Työkirja In Application.Workbooks
       Työkirja.Saved=True
    Next

    Application.Quit
    End Sub

    ei nyt muuta tuu mieleen tällä erää... jospa noilla probleema korjautuisi

    Keep Excelliong
    @Kunde
  6. tee haluamasi tunnisteet ja tallenna haluamallasi nimellä XLSTART kansioon. Nyt kun avaat excelin, niin se avaa tämän kansiossa olevan tiedoston automaattisesti...
    kansio on oletusasennuksella tuolla C:\Program Files\Microsoft Office\Office10\XLStart
  7. moduuliin...
    Option Explicit

    Sub AutoFit()
    Dim ws As Worksheet
    For Each ws In Worksheets
    ws.Activate
    Cells.EntireRow.AutoFit
    Cells.EntireColumn.AutoFit
    Next
    End Sub
  8. onhan sulla nyt varmasti haettavat viikot sarakkeessa D?
  9. kun en tiedä tarkemmin taulukon rakennetta niin tossa tommonen yleinen. Laittaa nyt lisättävän rivin A soluun kommentin, jossa muutoksen tekijän nimi ja aika. Helppo muutella toiveittesi mukaan

    keräilytaulukon moduuliin...

    Option Explicit
    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
    Target.Cells(1, 1).ClearComments
    Target.Cells(1, 1).AddComment.Text Text:=Format(Date, "mm-dd-yyyy") & Chr(10) & "Muokannut " & Environ("UserName")
    End If
    End Sub
  10. nyt ei väliä missä kohtaan sarakkeessa viikot on esim. tyyliin 31,32,31,33,32,31,31,31,32,32,32,34,35 jne.


    Dim EiTupla As New Collection
    Dim Taulukko As Worksheet
    Dim i As Integer
    Dim Löydetty As Range
    Dim Haku As Variant

    Sub LisääTaulukko()
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Worksheets("Sheet1").Activate
    Vika = Range("D65536").End(xlUp).Row
    For Each solu In Range("D1:D" & Vika)
    If Not IsEmpty(solu) Then
    EiTupla.Add solu.Value, CStr(solu.Value)
    End If
    Next solu
    For i = 1 To EiTupla.Count
    For Each Taulukko In Worksheets
    If Taulukko.Name = EiTupla(i) Then
    Taulukko.Delete
    End If
    Next Taulukko
    Sheets.Add.Name = EiTupla(i)
    ActiveSheet.Move After:=Sheets(Sheets.Count)
    Haku = EiTupla(i)
    Set Löydetty = EtsiJaSiirrä(Haku, Range("Sheet1!D1:D" & Vika)).EntireRow
    Union(Löydetty, Löydetty).Copy Range(Haku & "!A65536").End(xlUp).Offset(1, 0).EntireRow

    Next
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    End Sub

    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
  11. taulukoiden rajana koneen muisti...
    tolla nyt pääset alkuun ja sitä on helppo muokkailla itselle sopivaksi

    Option Explicit
    Sub LisääTaulukko()
    Dim Taulukko As Worksheet
    Dim Vika As String
    Dim solu As Range
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Sheet1").Activate
    Vika = Range("D65536").End(xlUp).Row
    For Each solu In Range("D1:D" & Vika)
    For Each Taulukko In Worksheets
    If Taulukko.Name = solu Then
    Taulukko.Delete
    End If
    Next Taulukko
    solu.EntireRow.Copy
    Sheets.Add.Name = solu
    ActiveSheet.Paste
    Range("A1").Select
    ActiveSheet.Move After:=Sheets(Sheets.Count)
    Next solu
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    End Sub

    Keep Exceling
    @Kunde
  12. kuten ekassa postauksessani sanoin, vaihda vakioita
    vauhda koodissa
    LookAt:=xlWhole--->LookAt:=xlPart
  13. Set Löydetty = EtsiJaSiirrä(R1C1).EntireRow
    ei tunnista tota R1C1 soluksi A1, all hiukan muunneltuna ja korjattuna makrot


    Function EtsiJaSiirrä(Hakuehto As Variant) As Range
    Dim solu As Range
    Dim EkaOsoite As String
    Worksheets("Sheet3").Activate
    With Cells
    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("Sheet1").Activate
    Range("A1").Select
    End Function

    Sub Testi()
    Dim Löydetty As Range
    Dim Haku As Variant

    On Error GoTo virhe
    Haku = Worksheets("Sheet1").Range("A1")
    Set Löydetty = EtsiJaSiirrä(Haku).EntireRow
    Union(Löydetty, Löydetty).Copy Range("Sheet1!A65536").End(xlUp).Offset(1, 0).EntireRow
    Exit Sub
    virhe:
    MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
    End Sub
  14. eräs JMS ei osannut kuin jossitella vähän... ja tällä tavalla hän oppi jossittelemaan lisää. alla linkkejä asian tiimoilta. vikassa taitaa olla se ratkaisu ;-)

    http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000013429271#22000000013429271

    http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000014687994#22000000014687994

    http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000018460202#22000000018460202
  15. moduuliin...
    etsii nyt sheet1:stä arvoa 11 ja siirtää löydetyt rivit sheet2:lle ekalle tyhjälle riville A- sarakkeessa
    muuttele vakioita tarpeesi mukaan...
    LookIn:=xlValues-xlFormulas
    LookAt:=xlWhole-xlPart
    MatchCase:=False-True

    Function EtsiJaSiirrä(Hakuehto As Variant) As Range
    Dim solu As Range
    Dim EkaOsoite As String
    Worksheets("Sheet1").Activate
    With Cells
    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 Testi()
    Dim Löydetty As Range
    On Error GoTo virhe
    Set Löydetty = EtsiJaSiirrä(11).EntireRow
    Union(Löydetty, Löydetty).Copy Range("Sheet2!A65536").End(xlUp).Offset(1, 0).EntireRow
    Exit Sub
    virhe:
    MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
    End Sub
  16. moduuliin...
    ja soluun mihin haluat tuloksen niin kaavaksi esim.
    =SummaVärillä(A1:A1000)

    HUOM!
    funktio ei päivity, kun muutat solun väriä joten se pitää resetoida esim. painamalla näppäinyhdistelmää CTRL+ALT+F9
    tietenkin tohon olis pitänyt lisätä eriväreille mahdollisuus, mutta olkoon nyt noin

    Function SummaVärillä(Alue As Range) As Double
    For Each solu In Alue
    If solu.Interior.ColorIndex = xlNone Then
    SummaVärillä = SummaVärillä + solu
    End If
    Next solu
    End Function
  17. moduuliin...

    Sub Kopioi()
    Dim Lähdealue As Range
    Dim vika As Integer

    vika = Range("G65536").End(xlUp).Row
    Set Lähdealue = Range("G1:G" & vika)
    Range("D2").Select
    For i = 1 To Lähdealue.Count
    ActiveCell = Lähdealue(i)
    ActiveCell.Offset(2, 0).Select
    Next
    End Sub

    Keep Exceling
    @Kunde
  18. kopioida kaava ja tyhjentää solun sisältö ja liittää taas siihen kaava - varsinkin jos tyhjennettävää on paljon. Kerkii siinä kahvit hörppiä kun makroa tehtäviään suorittaa ;-)

    aina kannattaa käyttää excelin omia komentoja, jos suinkin voi ne toimii nopeimmin (yleensä) aina.

    tuo luku 23 tulee siitä, että ynnätään yhteen allaolevat arvot seuraavasti

    virhearvo =16
    looginen arvo=4
    numeroarvo=1
    tekstiarvo=2

    eli jos haluat tyhjentää vain virheet niin luvuksi 16

    Sub Tyhjennä()
    Range("A1:F10000").SpecialCells(xlCellTypeConstants, 23).ClearContents
    End Sub

    mutta alkuperäiseen kysymykseen vastaten, ei ole mahdollista tyhjentää solua säilyttämällä siinä olevaa kaavaa!!!
  19. Äkkiseltään ei tule mieleen kuin kaavarivilllä maalaamalla funktiot.
    Eli jos solussa A1 on kaava =B1+C1+D1 (voi olla ihan mikä tahansa kaava)
    1. Maalaa B1 ja sitten paina F9 ja sitten
    2. Maalaa C1 ja paina F9 ja lopuksi
    3. Maalaa D1 ja paina F9.
    Kaavarivillä näet nyt kaavasi tuloksen jokaisen solun erillisenä tuloksena. Ihan sama mikä funktio on kunhan maalat oikein...
    4. Maalaa kaavarivi ja kopioi se
    5. Liitä haluamaasi soluun(laita hipsu tai tyhjä välilyönti alkuun)
    ja se on siinä...

    @Kunde
    Keep Excelling
  20. pikkusen kuukkelia ja löytyy muutama miljoona sivua asiasta ;) ja sivuja myös mistä ladata vanha menu...
    21. 58 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt