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. solumuotoilulla saat pari lisää, mutta koodilla sitten reippaasti lisää...

    taulukon moduuliin...
    ja nyt sarake C, muuta sopivaksi ja 7 ekaa kanssa

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim vika As Integer
    vika = Range("C65536").End(xlUp).Row
    For Each solu In Range("C1:C" & vika)
    Select Case Left(solu, 7)
    Case 1111111
    solu.Interior.ColorIndex = 3
    Case 1111112
    solu.Interior.ColorIndex = 4
    Case 1111113
    solu.Interior.ColorIndex = 5
    Case 1111114
    solu.Interior.ColorIndex = 7
    Case Else
    solu.Interior.ColorIndex = xlNone
    End Select
    Next

    End Sub

    tavalliseen moduuliin...

    tolla saat selville colorindexin numeroita vastaavat värit...

    Sub Värit()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim i As Long
    For i = 0 To 56
    Cells(i + 1, 1).Interior.ColorIndex = i
    Cells(i + 1, 1).Value = "[Väri " & i & "]"
    Cells(i + 1, 2).Font.ColorIndex = i
    Cells(i + 1, 2).Value = "Väri " & i
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    End Sub

    Keep Excelling
    @Kunde
  2. jos oikein tekee eli ...

    Sub Koe1()
    With Cells
    .Font.Size = 12
    .Font.Italic = True
    End With
    End Sub

    mutta makronauhottimella tehdessä olet siirtänyt kohdistuksen alkuperäisestä solusta pois, joten vaatii palautuksen esim. noin

    Sub Koe2()
    Dim Vanha As String
    Vanha = ActiveCell.Address
    'koodia...
    Range(Vanha).Select
    End Sub
  3. tuolla asiasta...

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

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

    http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000023942139#22000000023942139
  4. en tiedä OO mitään enkä haluakaan, mutta Excelillä se onnistuu...
    noin 3 vuotta sitten vastasin vastaavaan

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

    @Kunde
  5. muuta itsellesi sopivaksi. Avaa ekan taulukon nyt.

    normaali moduuliin...

    Private Sub Auto_Open()
    Sheets(1).Activate
    ActiveSheet.ScrollArea = "A1:Z50"
    End Sub

    ThisWorkbook moduuliin...

    Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    ActiveSheet.ScrollArea = "A1:Z50"
    End Sub
  6. mutta voit tehdä ton piirtovalikon objekteilla ja liittää siihen kuvan ja kirjoittaa siihen tekstiä ihan normaalisti tai linkittää tekstin muualta
  7. Lajittele sarakkeet ekaksi H ja sitten K sarakkeen mukaan ja sulla on 3 suurinta/pienintä arvoa 3 ylimmillä rivillä...
  8. kopioitavan taulukon moduuliin...
    kopioi nyt TAul2, muuta sopivaksi

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Cells.Copy Destination:=Sheets("Taul2").Range("A1")

    End Sub
  9. taulukon moduuliin...
    oletuksena otsikot ekalla rivillä
    muokkaa sopivaksi järjestys ja useammat sarakkeet, nyt lajittelee tuplaklikkauksella mistä tahansa solusta ko. solun sarakkeen mukaan...

    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim vika As Long
    vika= Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row
    Rows("2:" & vika).Sort Key1:=Cells(2, ActiveCell.Column), _
    Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom
    End Sub

    Keep Excelling
    @Kunde
  10. VBA:lla ihan piece of cake, mutta normaalikaavoilla aika paha...

    ei toimi ennenkuin 5 ei 0-arvoa on alueella. Muuta aluetta tarvittaessa, tietenkin alueen vosi vielä muuttaa dynaamiseksi,mutta jääköön se sun tehtäväksi, koska sen jo osaatkin

    siis haluamaasi soluun kaava
    =SUM(OFFSET($A$1;LARGE(IF(ISNUMBER($A$1:$A$100);IF($A$1:$A$1000;ROW($A$1:$A$100)));5)-1;0;100;))

    ja muista, että kaava on matriisikaava,joten kaavarivillä ENTERin sijasta CTRL+SHIFT+ENTER

    Keep Exceling
    @Kunde
  11. ilmeisesti kyse on viivakoodin tarkisteen laskemisesta
    solussa A1 laskettu summa
    tarkistenumero 2 saadaan kaavalla = MOD(A1,103)
    suomiversiossa MOD taitaa olla JAKOJ
  12. normaali array-lajittelulla onnistuu
    nimet A-sarakkeessa ja aakkostaa B-sarakkeeseen

    Sub Aakkosta()
    Dim rarray As Variant
    Dim Vika As Double
    Dim lkm As Long
    Dim lkm2 As Long
    Dim Nimi1 As String
    Dim Nimi2 As String

    On Error Resume Next

    Application.ScreenUpdating = False
    Range("B:B")= ""

    Vika = Range("A65536").End(xlUp).Row
    rarray = WorksheetFunction.Transpose(Range("A1:A" & Vika).Value)

    For lkm = 1 To UBound(rarray)
    For lkm2 = lkm To UBound(rarray)
    If UCase(rarray(lkm2)) < UCase(rarray(lkm)) Then
    Nimi1 = rarray(lkm)
    Nimi2 = rarray(lkm2)
    rarray(lkm) = Nimi2
    rarray(lkm2) = Nimi1
    End If
    Next lkm2
    Next lkm

    Range("B1:B" & UBound(rarray)) _
    = WorksheetFunction.Transpose(rarray)
    Application.ScreenUpdating = True
    End Sub
  13. sarakkeeseen solumuotoiluksi
    0;0;"-";@ tai jos desimaaleja haluat esim. 2
    0,00;0,00;"-";@

    ja sitten vain lajittelu...
  14. Mitenkas kuvat lisatty taulukkoon?
    Onko kuvat aina saman nimisessa taulukossa?
    Onko tyokirjan tauluko(i)ssa muita kuvia?
    yms...
    kun tarvittavat tiedot, niin toi on ihan piece of cake :-)
    jos voit lahettaa mulle mallitaulukon, niin teen sulle makron
    [email protected]
  15. oikein vaan tayttaa koko sarakkeen ja ...

    moduuliin...

    Sub TaytaTyhjat()
    Dim vika As Long
    On Error Resume Next
    vika = Range("A65536").End(xlUp).Row
    Range("A1:A" & vika).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    End Sub
  16. Excelin omilla funktioilla

    ThisWorkbook moduuliin...

    Private Sub Workbook_BeforePrint(Cancel As Boolean)
    Dim vika As Integer
    vika = Range("O65536").End(xlUp).Row
    ActiveSheet.PageSetup.PrintArea = "$A$1:$O$" & vika
    End Sub
  17. nyt ei näy ruudukkoa...

    Sub ExcelistäWordiin()

    Dim oWord As Word.Application
    Dim oDoc As Word.Document
    Dim ws As Worksheet

    On Error Resume Next

    Set oWord = GetObject(, "Word.Application")
    If Err Then
    Set oWord = New Word.Application
    End If

    On Error GoTo virhe
    oWord.DisplayAlerts = wdAlertsNone
    oWord.Visible = True
    oWord.Activate
    Set oDoc = oWord.Documents.Add
    For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "Sheet8" Or ws.Name = "Sheet9" Then
    ws.UsedRange.Copy
    oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.InsertParagraphAfter
    oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=True


    Application.CutCopyMode = False
    oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.InsertParagraphAfter

    If Not ws.Name = Worksheets(Worksheets.Count).Name Then
    With oDoc.Paragraphs(oDoc.Paragraphs.Count).Range
    .InsertParagraphBefore
    .Collapse Direction:=wdCollapseEnd
    .InsertBreak Type:=wdPageBreak
    End With
    End If
    End If
    Next ws
    For Each aTable In oWord.ActiveDocument.Tables
    aTable.ConvertToText wdSeparateByTabs, True
    Next aTable
    oDoc.Saved = True
    oWord.DisplayAlerts = wdAlertsAll
    Set oWord = Nothing
    Set oDoc = Nothing
    Exit Sub

    virhe:
    oWord.DisplayAlerts = wdAlertsAll
    oWord.Quit
    End Sub
  18. en tiedä miten excelin ruudukon voisi poistaa näkymästä muuten kuin kikkailemalla. Toisaalta taas kopioimalla excelistä solu kerrallaan on liian hidasta...

    Sub ExcelistäWordiin()

    Dim oWord As Word.Application
    Dim oDoc As Word.Document
    Dim ws As Worksheet

    On Error Resume Next

    Set oWord = GetObject(, "Word.Application")
    If Err Then
    Set oWord = New Word.Application
    End If

    On Error GoTo virhe
    oWord.DisplayAlerts = wdAlertsNone
    oWord.Visible = True
    oWord.Activate
    Set oDoc = oWord.Documents.Add
    For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "Sheet8" Or ws.Name = "Sheet9" Then
    ws.UsedRange.Copy
    oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.InsertParagraphAfter
    oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=True


    Application.CutCopyMode = False
    oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.InsertParagraphAfter

    If Not ws.Name = Worksheets(Worksheets.Count).Name Then
    With oDoc.Paragraphs(oDoc.Paragraphs.Count).Range
    .InsertParagraphBefore
    .Collapse Direction:=wdCollapseEnd
    .InsertBreak Type:=wdPageBreak
    End With
    End If
    End If
    Next ws
    oDoc.Saved = True
    oWord.DisplayAlerts = wdAlertsAll
    Set oWord = Nothing
    Set oDoc = Nothing
    Exit Sub

    virhe:
    oWord.DisplayAlerts = wdAlertsAll
    oWord.Quit
    End Sub
  19. Function OnkoAuki(Nimi As String) As Boolean
    On Error Resume Next
    Set Työkirja = Workbooks(Nimi)
    If Työkirja Is Nothing Then
    OnkoAuki = False
    Set wBook = Nothing
    On Error GoTo 0
    Else
    OnkoAuki = True
    Set wBook = Nothing
    On Error GoTo 0
    End If
    End Function

    Sub koe()
    If OnkoAuki("Heikki.xls") Then
    MsgBox "Työkirja on jo avoinna"
    Else
    MsgBox "Työkirja ei ole avoinna"
    End If
    End Sub
  20. löytyy vaikka kuinka paljon ohjeita
    esim tässä hyvät ohjeet outlookin manipuloimiseen
    http://www.dicks-clicks.com/excel/olAutomating.htm
    21. 59 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt