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. pari päivää sitten vastasin samanlaiseen kyssäriin...

    http://keskustelu.suomi24.fi/node/9654096
  2. mutta aikaa ja kahvia menee...
    nyt et kerkiä hörpätä edes kahvia kun jo valmis ;-)

    ei ole virhetarkasteluja eikä muitakaan "säätöjä", joten makro "kaatuu", jos on jo ennestään saman niminen taulukko (eli raporttixx).

    Sub LisääTaulukko()
    For i = 1 To 200
    Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    taulukko.Name = "raportti" & i
    Set taulukko = Nothing
    Next i
    End Subub
  3. aktiivisen taulukon saa funktiolla
    =MID(CELL("filename");FIND("]";CELL("filename"))+1;255
    muut taulukot sitten hankalaa räpeltämistä... esim laittamalla saman koodin muihin taulukoihin samaan soluun ja sitten linkittöö sen solun jne...

    VBa siisti ja simppeli aktiiviseen taulukkoon alkaen solusta A1

    Sub TaulukonNimet()
    For i = 1 To Sheets.Count
    Range("A" & i) = Sheets(i).Name
    Next i
    End Sub

    tai omana funktiona soluun haluttu taulukon nimi esim. ==TaulukonNimi(1)

    Function TaulukonNimi(Indeksi As Integer) As String
    On Error GoTo virhe
    TaulukonNimi = Sheets(Indeksi).Name
    Exit Function
    virhe:
    TaulukonNimi = "Ei tietoa???"
    End Function

    Keep EXCELing
    @Kunde
  4. oma solumuotoilu esim. ppp lyhyenä ma,ti,ke.. ja pppp maanantai,tiistai,keskiviikko
  5. Sub Siirrä()
    Dim vika As Long
    vika = Range("A65536").End(xlUp).Row
    Sheets("Sheet1").Activate
    For Each solu In Range("A2:A" & vika)
    session.findById("wnd[0]").maximize
    session.findById("wnd[0]/mbar/menu[1]/menu[3]").Select
    session.findById("wnd[0]/usr/ctxt[0]").Text = solu.Offset(0, 1)
    session.findById("wnd[0]/usr/ctxt[4]").Text = solu
    session.findById("wnd[0]/usr/ctxt[4]").SetFocus
    session.findById("wnd[0]/usr/ctxt[4]").caretPosition = 7
    session.findById("wnd[0]").sendVKey 0
    Next
    MsgBox "ALL " & vika - 1 & " Excel rows processed"
    End Sub

    Keep EXCELing
    @Kunde
  6. lisäsin malliksi aikamuotoilun, jota on helppo muotoilla...

    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Not Intersect(Range("A1:A200"), Target) Is Nothing Then
    If Not Target = "" Then
    Target.Offset(0, 1) = Format(Now(), "dd.mm.yyyy hh:mm:ss")
    End If
    End If
    End Sub
  7. tietämättä tarpeitasi tossa alla yleisluontoinen esim.
    eli tsekataan A2 solua ja kun soluun syötetään arvo, niin soluun B2 tulee kellonaika. Tee soluun B2 sopiva solumuotoilu.
    Solun B2 arvo ei muutu, vaikka muut solut muuttusivatkin toisin kuin noilla volatile eli ei pysyvillä Excelin omilla funktioilla.
    Solun B2 arvo muuttuu vain siinä tapauksessa, kun solu A2 on tyhjennetty ja uudelleen syötetään arvo siihen

    taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("A2"), Target) Is Nothing Then
    If Not Range("A2") = "" Then
    Range("B2") = Now()
    End If
    End If
    End Sub

    Keep EXCELing
    @Kunde
  8. jos ei ole muita objekteja käytössä kuin kuvia, niin onnistuu kuvan poisto myös ilman koodia
    EDIT/ Go To/avautuvassa valikossa Special ja edelleen avautuvasta valikossa ruksi ruutuun Objects
    Ok ja delete
  9. poistaa aktiivisesta taulukosta kuvat

    moduuliin...

    Sub PoistaKuvat()
    For Each Picture In ActiveSheet.Pictures
    Picture.Delete
    Next
    End Sub

    Keep EXCELing
    @Kunde
  10. kaikkeahan saa luettua ja kirjoiteltua koodilla. Eri asia sitten miten ne saa päiviteltyä helposti, kun Wordissa ei ole valmiina tapahtumille koodia ja ne pitää sitten itse väsäillä.
    Helpoimmalla sun tapauksessahan olisi päässsyt koodaamalla kirjainmerkkiin, mutta kun nyt halusit kenttään niin olkoon menneeksi...

    liitä koodit Normal.dot ThisWorkbook moduuliin ja koodit on sitten aina käytössäsi ilman uudelleen kirjoittamista...
    Voit tehdä napit helpottamaan elämääsi ja liittää koodit niihin.

    Nyt kun ajat koodin Lisää() se lisää kenttäluettelon DocProperty nimen ominaisuuksiin Kuvienlkm.
    Eli Kuvienlkm toimii ihan kuten normaalitkin ominaisuudet(löytyy listasta) ja lisää kenttään koodin
    {DOCPROPERTY Kuvienlkm \* MERGEFORMAT}

    Päivitys ei oikein ole Wordin vahvoja puolia, joten sekin sitten koodilla Päivitä()...

    Sub Päivitä()
    Dim jutska As Range
    Dim kenttä As Field
    Dim objCustomProperties As DocumentProperties
    Set objCustomProperties = ActiveDocument.CustomDocumentProperties
    objCustomProperties.Item("Kuvienlkm").Value = ActiveDocument.InlineShapes.Count

    For Each jutska In ActiveDocument.StoryRanges
    For Each kenttä In jutska.Fields
    kenttä.Update
    Next kenttä
    Next jutska
    Set jutska = Nothing
    Set kenttä = Nothing
    End Sub

    Sub Lisää()
    Dim objCustomProperties As DocumentProperties
    On Error Resume Next
    Set objCustomProperties = ActiveDocument.CustomDocumentProperties
    objCustomProperties.Add Name:="Kuvienlkm", Type:=msoPropertyTypeString, Value:=ActiveDocument.InlineShapes.Count, LinkToContent:=False
    End Sub

    Keep WORDing
    @Kunde
  11. Sub Transponoi()
    Dim vika As Long
    Dim vika2 As Long
    Dim solu As Range
    On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets("Taul2").Range("B:B") = ""
    vika = Range("Taul1!A65536").End(xlUp).Row
    vika2 = Range("Taul1!C65536").End(xlUp).Row
    If vika < vika2 Then
    vika = vika2
    End If
    For Each solu In Range("A1:A" & vika)
    solu.Copy
    Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
    If Not solu.Offset(0, 2).Text = "#N/A" Then
    solu.Offset(0, 2).Copy
    Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
    End If
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    End Sub

    Keep EXCELling
    @Kunde
  12. Sub Transponoi()
    Dim vika As Long
    Dim vika2 As Long
    Dim solu As Range
    On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets("Taul2").Range("B:B") = ""
    vika = Range("Taul1!A65536").End(xlUp).Row
    vika2 = Range("Taul1!C65536").End(xlUp).Row
    If vika < vika2 Then
    vika = vika2
    End If
    For Each solu In Range("A1:A" & vika)
    solu.Copy
    Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
    solu.Offset(0, 2).Copy
    Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    End Sub
  13. Sub Transponoi()
    Dim vika As Long
    Dim vika2 As Long
    Dim solu As Range
    Worksheets("Taul2").Range("B:B") = ""
    vika = Range("Taul1!A65536").End(xlUp).Row
    vika2 = Range("Taul1!C65536").End(xlUp).Row
    If vika < vika2 Then
    vika = vika2
    End If
    For Each solu In Range("A1:A" & vika)
    solu.Copy Range("Taul2!B65536").End(xlUp).Offset(1, 0)
    solu.Offset(0, 2).Copy Range("Taul2!B65536").End(xlUp).Offset(1, 0)
    Next
    Application.CutCopyMode = False
    End Sub
  14. Sub Transponoi()
    Dim vika As Integer
    Dim solu As Range
    Worksheets("Taul2").Range("B:B") = ""
    vika = Range("Taul1!A65536").End(xlUp).Row
    For Each solu In Range("Taul1!A1:C" & vika)
    solu.Copy
    Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    Next
    Application.CutCopyMode = False
    End Sub
  15. Sub Transponoi()
    Dim vika As Integer
    Dim solu As Range

    Worksheets("Taul2").Range("B:B") = ""

    'a- sarake
    vika = Range("Taul1!A65536").End(xlUp).Row
    For Each solu In Range("Taul1!A1:A" & vika)
    solu.Copy
    Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    Next

    'c sarake
    vika = Range("Taul1!C65536").End(xlUp).Row
    For Each solu In Range("Taul1!C1:C" & vika)
    solu.Copy
    Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    Next

    Application.CutCopyMode = False
    End Sub

    Keep EXCELling
    @Kunde
  16. haetaanko avoimesta vaiko suljetusta tiedostosta?
    Yhdestä vaiko monesta tiedostosta?
    Yhdestä vaiko monesta taulukosta
    Mitä haetaan ja minkälainen on hakualueen rakenne...

    Keep EXCELling
    @Kunde
  17. Sub LAskeTyhjätVälit2()
    Dim vika As Long
    Dim i As Long
    Dim rivi As Long
    Dim tulos As String

    Range("AH:AH").Clear

    For rivi = 5 To 370

    vika = Range("IV" & rivi).End(xlToLeft).Column

    For i = 2 To Range(Cells(5, 5), Cells(5, vika)).SpecialCells(xlCellTypeBlanks).Areas.Count
    tulos = tulos & Range(Cells(5, 5), Cells(5, vika)).SpecialCells(xlCellTypeBlanks).Areas(i).Cells.Count & ", "
    Next

    If Not tulos = "" Then
    Range("AH" & rivi) = Left(tulos, Len(tulos) - 2)
    tulos = ""
    End If

    Next
    Range("AH:AH").NumberFormat = "@"
    Range("AH:AH").EntireColumn.AutoFit
    End Sub

    Keep Excelling
    @Kunde
  18. laskee nyt A-sarakkeesta tyhjät välit alkaen solusta A1 viimeiseen riviin asti ja tulostaa F1 soluun. Tyhjiä välejä voi olla useampiakin kuin pyytämäsi 2

    moduuliin...

    Sub LAskeTyhjätVälit()
    Dim vika As Long
    Dim i As Long
    Dim tulos As String
    vika = Range("A65536").End(xlUp).Row
    For i = 2 To Range("A1:A" & vika).SpecialCells(xlCellTypeBlanks).Areas.Count
    tulos = tulos & Range("A1:A" & vika).SpecialCells(xlCellTypeBlanks).Areas(i).Cells.Count & ", "
    Next
    Range("F1") = Left(tulos, Len(tulos) - 2)
    End Sub

    Keep Excelling
    @Kunde
  19. muuttele taulukoiden nimet, hakualue ja värikoodi (pun=3) sopivaksi
    moduuliin...

    Option Explicit

    Sub EtsiJaSiirrä()
    Dim solu As Range
    Dim vika As Long
    On Error Resume Next
    Worksheets("Sheet2").Cells.Clear
    Worksheets("Sheet1").Activate
    vika = Range("C65536").End(xlUp).Row
    For Each solu In Range("C1:C" & vika)
    If solu.Interior.ColorIndex = 3 Then
    solu.EntireRow.Copy Range("Sheet2!A65536").End(xlUp).Offset(1, 0)
    End If
    Next
    End Sub

    Keep Excelling
    @Kunde
  20. esim. solussa F1 taulukonnimi
    soluun kaava =INDIRECT(F1& "!A1") tai =EPÄSUORA(F1& "!A1")
    21. 38 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt