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. lisää referenssi Microsoft Scripting Runtime
    Dim rivi As Long
    Sub Alikansiot()
    Sheets("Hyperlinkit").Cells = ""
    HaeAlikansiot "H:"
    JaaAlikansioihin
    Columns("A:IV").AutoFit
    End Sub

    Sub HaeAlikansiot(Kansio As String)

    Dim FSO As Scripting.FileSystemObject
    Dim Lähde As Scripting.Folder
    Dim Alikansio As Scripting.Folder

    Set FSO = New Scripting.FileSystemObject
    Set Lähde = FSO.GetFolder(Kansio)
    rivi = Range("A65536").End(xlUp).Row + 1
    Cells(rivi, 1).Formula = Lähde.Path
    Cells(rivi, 1).Hyperlinks.Add Anchor:=Cells(rivi, 1), Address:=Lähde.Path
    For Each Alikansio In Lähde.SubFolders
    HaeAlikansiot Alikansio.Path
    Next Alikansio

    Set Alikansio = Nothing

    Set Lähde = Nothing
    Set FSO = Nothing
    End Sub

    Sub JaaAlikansioihin()
    Dim a As Variant
    Dim i As Long
    Dim j As Integer
    On Error GoTo virhe
    rivi = Range("A65536").End(xlUp).Row
    For i = 136 To rivi
    a = Split(Range("A" & i), "\")
    Cells(i, 1).Hyperlinks.Add Anchor:=Cells(i, 1), Address:=Range("A2") & "\" & a(2)
    For j = 1 To UBound(a)
    If j >= 3 Then
    Cells(i, j - -1).Hyperlinks.Add Anchor:=Cells(i, j - 1), Address:=Cells(i, j - 2) & "\" & a(j)
    End If


    Next
    Next
    virhe:
    End Sub
  2. kuten viestissä mainitaan

    ' lisää referenssi Microsoft Scripting Runtime
    Sub Alikansiot()
    Sheets("Hyperlinkit").Cells = ""
    HaeAlikansiot "H:\Excel\" ' muuta kansiopolku
    End Sub

    et ole lisännyt viittausta
  3. moduuliin...

    ' lisää referenssi Microsoft Scripting Runtime
    Sub Alikansiot()
    Sheets("Hyperlinkit").Cells = ""
    HaeAlikansiot "H:\Excel\" ' muuta kansiopolku
    End Sub

    Sub HaeAlikansiot(Kansio As String)

    Dim FSO As Scripting.FileSystemObject
    Dim Lähde As Scripting.Folder
    Dim Alikansio As Scripting.Folder
    Dim rivi As Long

    Set FSO = New Scripting.FileSystemObject
    Set Lähde = FSO.GetFolder(Kansio)
    rivi = Range("A65536").End(xlUp).Row + 1
    Cells(rivi, 1).Formula = Lähde.Path
    Cells(rivi, 1).Hyperlinks.Add Anchor:=Cells(rivi, 1), Address:=Lähde.Path
    For Each Alikansio In Lähde.SubFolders
    HaeAlikansiot Alikansio.Path
    Next Alikansio
    Set Alikansio = Nothing
    Columns("A").AutoFit
    Set Lähde = Nothing
    Set FSO = Nothing
    End Sub
  4. Koska solut on yhdistetty ei suodatus toimi, koska yhdistetyissä soluissa on tietoa vain sen vasemman yläkulman solussa, joten ainoa mahdollisuus on tehdä makro.
    Makrolla puretaan yhdistetyt solut ja täytetään ne ao tiedoilla, jolloin suodatus toimii...
    Alla nyt simppeli esim. asiasta. Muokkaa mieleiseksi.
    Nyt originaalitiedot Data nimisessä taulukossa, jonka nimi pitää muuttaa sopivaksi.
    Ohjelma aluksi kysyy maanosaa ja tekee sen mukaisen suodatuksen Huuhaa(muuta mieleiseksi) taulukkoon. Sen jälkeen voit tehdä tehdä vapaasti suodatuksia eri kentille alasvetovalikoista.

    Sub Pikasuodatus()
    Dim Hakuehto As String
    Dim Alue As Range
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set Alue = Sheets("Data").Range("A1").CurrentRegion ' vaihda nimi originaalitiedot tässä
    Sheets("Huuhaa").Delete
    Worksheets.Add().Name = "Huuhaa"
    Alue.Copy Destination:=Sheets("Huuhaa").Range("A1")
    Hakuehto = Application.InputBox("Anna maanosan nimi jonka tietoja haluat tutkia", "Hakukone", "Eurooppa", Type:=2)
    Set Alue = Sheets("Huuhaa").Range("A1").CurrentRegion
    With Alue
    .UnMerge
    .Resize(.Rows.Count, 1).SpecialCells(xlBlanks).Formula = "=R[-1]C"
    Range("A1").AutoFilter Field:=1, Criteria1:=Hakuehto
    End With
    Range("A1").Select

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub

    Keep Excelling!
    @Kunde
  5. "Toki sillä mainitsemallasi suodatuksella olisi iisiä tehdä suodatus esim. antenneista ja sitten kopsata ko. lista sinne antennit-taulukkoon, mutta kun pahoin pelkään että työnantaja ei sitäkään vaivaa halua nähdä :/. "

    en minäkään viitsisi pelleillä phauilla ja suodatuksilla manuaalisesti...

    mutta asiaan

    en tarkkaan tiedä tuotteiden koodaustasi, mutta allaoleva makro päivittää automaattisesti taulukot ja lisää uuden kun uusi tuote lisätään. Tosta on helppo muunnella tarpeittesi mukaan. Tuotteet on siis sarakkeessa A, josta uudet taulukot tehdään

    Datataulukon moduuliin...

    rivate Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo virhe
    Application.ScreenUpdating = False
    Call TeeTaulukot
    virhe:
    Application.ScreenUpdating = True
    End Sub

    ja tavalliseen moduuliin...

    Sub TeeTaulukot()
    Dim Tiedot As Range
    Dim solu As Range
    Dim Taulukko As Worksheet
    Dim AloitusTaulukko As Worksheet
    Dim Nimi As String


    On Error Resume Next
    Application.DisplayAlerts = False
    Set AloitusTaulukko = ActiveSheet
    AloitusTaulukko.AutoFilterMode = False
    Set Tiedot = Range("A1", Range("A65536").End(xlUp))
    For Each Taulukko In Worksheets
    If Not Taulukko.Name = "Data" Then ' muuta datataulukon nimi sopivaksi
    Taulukko.Delete
    End If
    Next

    Worksheets.Add().Name = "HUUHAA"
    With Worksheets("HUUHAA")
    Tiedot.AdvancedFilter xlFilterCopy, , _
    Worksheets("HUUHAA").Range("A1"), True
    Set Tiedot = .Range("A1", .Range("A65536").End(xlUp))
    End With

    With AloitusTaulukko
    For Each solu In Tiedot
    Nimi = solu
    .Range("A1").AutoFilter 1, Nimi
    Worksheets.Add().Name = Nimi
    .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
    ActiveSheet.Cells.Columns.AutoFit
    Next solu
    End With

    With AloitusTaulukko
    .AutoFilterMode = False
    .Activate
    End With

    On Error GoTo 0
    Worksheets("HUUHAA").Delete
    Application.DisplayAlerts = True
    End Sub

    keep excelling :-)
    @Kunde
  6. moduuliin...

    Sub Väli()
    Dim alkupvm As Variant
    Dim tokapvm As Variant
    Range("A1").Select
    alkupvm = Weekday(ActiveCell)
    Do Until IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
    tokapvm = Weekday(ActiveCell)
    If tokapvm alkupvm Then
    ActiveCell.EntireRow.Insert
    ActiveCell.Offset(1, 0).Select
    End If
    alkupvm = tokapvm
    Loop
    End Sub
  7. soluun mihin haluat nollat piiloon
    Range("A1").NumberFormat = "0.00;0.00;"
  8. aivan sivun lopussa
    http://www.cpearson.com/excel/duplicat.htm
  9. nyt haluamasi toiminto soluun C1 ja alasvetovalikko soluista A1:A10 ja soluun voi syöttää muitakin arvoja.
    Ilman VBA:ta voit tehdä saman tekemällä kelpoisuusehdon listasta ja poistat ruksin virheilmoitus välilehdeltä

    Sub Kelpoisuusehto()
    With Range("C1").Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:="=$A$1:$A$10"
    .ShowError = False
    End With
    End Sub
  10. aika simppelisti toi onnistuu excelin omilla erikoistoiminnoilla...

    Sub Siirrä()
    Dim KopioAlue As Range 'kopioitava alue
    Dim SiirtoAlue As Range ' kohdealue
    Dim EiTyhjiäAlue As Variant ' eityhjiä rivejä originaali kopioitava alue
    On Error Resume Next
    Set KopioAlue = Sheets("Originaali").Range("A1:B23") 'muuta kopioitavan taulukonnimi
    KopioAlue.SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True ' tyhjät piilotetaan
    Set EiTyhjiäAlue = KopioAlue.SpecialCells(xlCellTypeVisible) ' kopioidaan vain näkyvät
    Set SiirtoAlue = Sheets("Kopio").Range("A1:B23") ' muuta kohdetaulukon nimi
    If WorksheetFunction.CountA(SiirtoAlue) = 0 Then 'onko kohdealue tyhjä...
    EiTyhjiäAlue.Copy Destination:=SiirtoAlue ' kopioidaan tiedot
    Else ' jos ei niin etsitään eka tyhjä oikealle
    EiTyhjiäAlue.Copy Destination:=SiirtoAlue.End(xlToRight).Offset(0, 1) ' kopioidaan tiedot
    End If
    KopioAlue.SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = False ' tyhjät näkyviin taas
    End Sub

    keep excelling!
  11. Sub summaa()
    Dim summa As Double
    For i = 1 To Worksheets.Count
    If Worksheets(i).Visible = True Then
    summa = summa + Worksheets(i).Range("A1")
    End If
    Next i
    Worksheets(1).Range("F1") = summa
    End Sub
  12. jos työkirja sisältää kaavioita. On mennyt käsitteet Sheet ja Worksheet vähän sekaisin...
    keep Excelling
  13. =JOS(VERTAA($D$9;"X");$L$19*1000/JOS(VERTAA($A$13;"X")...

    ainakin jos D9=x ja A13X niin silloinhan tulee virhe kun jaetaan nollalla!

    en kyllä ymmärrä kaavaasi
    $L$19*1000/JOS(VERTAA($A$13;"X")
    jaetaan joko 1 tai 0 eli ilmeisesti sun jossittelu ei mene oikein...
    VBA:n avulla voit tehdä monesti kaavan paljon helpomminkin VBA:n omilla jutuilla
    joten tarkistappas nyt ekaksi jossittelusi
  14. mutta kokeiles ensiksi esim.
    Range("A1").FormulaLocal= "..."
  15. niin nauhoita makro ja katso mitä se on saanut aikaan...(98% paskaa...)
    mutta asiaan...
    kirjoita koodiin esim. riippuen kieliversiosta
    Range("F16").Formula = "=SUM(A1:A10)" tai
    Range("F16").Formula = "=SUMMA(A1:A10)"

    voit katsoa myös mitä muita vaihtoehtoja löytyy(auora tai suhteellinen viittaus) kun kirjoittelet VBAeditorissa
    Range("F16"). ja katselet mitä vaihtoehtoja löytyy
    Keep Excelling
  16. tässä nyt esim. hiiren oikeaan valikkoon

    ThisWorkbook moduuliin...

    Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim Nappi As CommandBarButton
    On Error Resume Next
    Application.CommandBars("Cell").Controls("Taulukot").Delete
    On Error GoTo 0
    Set Nappi = Application.CommandBars("Cell").Controls.Add(Type:=msoControlButton, Temporary:=True)
    With Nappi
    .Caption = "Taulukot"
    .OnAction = "AvaaTaulukko"
    End With
    End Sub


    ja moduuliin...

    Sub AvaaTaulukko()
    Application.CommandBars("workbook Tabs").ShowPopup
    End Sub
  17. Sub Näkyvät()
    For i = 1 To Sheets.Count
    If Sheets(i).Visible = True Then
    MsgBox Sheets(i).Name
    End If
    Next
    End Sub
  18. moduuliin

    Sub Kopioi()
    On Error Resume Next
    Dim vika As Integer
    Dim x As Integer
    Sheets("Taul1").Activate
    Sheets("Taul2").Range("A:B") = ""
    Range("Taul2!A2") = "Otsikko1"
    vika = Range("A65536").End(xlUp).Row
    For Each solu In Range("A2:B" & vika)
    solu.Copy Destination:=Range("Taul2!B65536").End(xlUp).Offset(1, 0)
    x = x + 1
    If x Mod 2 = 0 Then
    Range("Taul2!A65536").End(xlUp).Offset(1, 0) = "Otsikko1"
    Else
    Range("Taul2!A65536").End(xlUp).Offset(1, 0) = "Otsikko2"
    End If
    Next
    Range("Taul2!A65536").End(xlUp) = ""
    Rows("1:1").Delete
    'vika = Range("Taul2!A65536").End(xlUp).Row
    'ActiveSheet.PageSetup.PrintArea = "$A$1:$B$" & vika
    End Sub
  19. kumpaako inputboxia käytät
    esim.
    Sub koe()
    x = InputBox("Anna luku")
    If x = "" Then
    MsgBox "Peruutit toiminnan", vbInformation
    End If
    x = Application.InputBox("Anna luku")

    If x = False Then
    MsgBox "Peruutit toiminnan", vbInformation
    End If

    End Sub
  20. mutta luepas vaikka tuolta hyvät ohjeistukset. en jaksa itse nyt kirjoitella
    eli ratkaisu on OFFSET eli SIIRTYMÄ

    http://www.tushar-mehta.com/excel/newsgroups/dynamic_charts/index.html#BasicRange
    21. 63 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt