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

1377

  1. taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Not Intersect(Target, Range("A1")) Is Nothing Then
    If IsNumeric(Target) Then
    Range("B1") = Range("B1") + Range("A1")
    Else
    MsgBox "syottämäsi arvo ei ollut luku! "
    Range("A1").Select
    Exit Sub
    End If
    End If
    End Sub
  2. moduuliin...

    Sub koe()
    Dim Sivunalku As String
    Dim Alue As Range
    Dim i As Integer
    Dim j As Integer
    Dim alkuwb As String
    Dim uusiwb As String
    Dim Sivunvaihto As Integer
    Dim Rivit As Long
    Dim Polku As String
    Dim Sivunkoko As Integer

    On Error GoTo virhe
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    takaisin:
    Sivunkoko = Application.InputBox(" Anna rivienmaara sivulla", "Sivuntulostus", 30, Type:=1)
    If Sivunkoko = 0 Then Exit Sub
    If Not Sivunkoko > 0 Then
    MsgBox "Sinun on annettava 0 suurempi luku!"
    GoTo takaisin
    End If
    Rivit = ActiveSheet.UsedRange.Rows.Count
    ActiveSheet.ResetAllPageBreaks
    If Rivit > Sivunkoko Then
    Sivunvaihto = Int(Rivit / Sivunkoko) + 1
    For i = 1 To Sivunvaihto
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveSheet.UsedRange.Cells(Sivunkoko * i + 1, 1)
    Next i
    End If
    alkuwb = ActiveWorkbook.Name
    Sivunalku = "$A$1"

    For i = 1 To ActiveSheet.HPageBreaks.Count
    uusi = i
    If i > 1 Then Sivunalku = ActiveSheet.HPageBreaks(i - 1).Location.Address
    j = ActiveSheet.HPageBreaks(i).Location.Row - 1

    Workbooks.Add
    uusiwb = ActiveWorkbook.Name
    Workbooks(alkuwb).Sheets(1).Range(Sivunalku & ":" & "$H$" & Trim$(Str$(j))).Copy _
    Destination:=Workbooks(uusiwb).Sheets(1).Range("A1") ' oletus eka taulukko
    Polku = "H:\" & uusi & ".xls" 'muuta polkua
    ActiveWorkbook.SaveAs Filename:=Polku
    ActiveWorkbook.Close
    Windows(alkuwb).Activate

    Next
    ' vika sivu lisattava manuaalisesti
    If j < Rivit Then
    uusi = uusi + 1
    j = j + Sivunkoko
    Sivunalku = Range(Sivunalku).Offset(Sivunkoko, 0).Address
    Workbooks.Add
    uusiwb = ActiveWorkbook.Name
    Workbooks(alkuwb).Sheets(1).Range(Sivunalku & ":" & "$H$" & Trim$(Str$(j))).Copy _
    Destination:=Workbooks(uusiwb).Sheets(1).Range("A1") ' oletus eka taulukko
    Polku = "H:\" & uusi & ".xls" 'muuta polkua
    ActiveWorkbook.SaveAs Filename:=Polku
    ActiveWorkbook.Close
    Windows(alkuwb).Activate
    End If
    virhe:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub


    keep Excelling
    @Kunde
  3. pelkillä boolean operaattoreilla ja on helppolukuisempi ja ei ole sitä jossien 7 sisäkkäissääntoä (ennen versiota 2007)

    =(B3*0,25*A5*G13)*((A3>=5)*0,2+(A3>=10)*0,1+(A3>=15)*0,1+(A3>=20)*0,1+(A3>=25)*0,1)
  4. 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
  5. 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
  6. 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
  7. 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
  8. "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
  9. 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
  10. soluun mihin haluat nollat piiloon
    Range("A1").NumberFormat = "0.00;0.00;"
  11. aivan sivun lopussa
    http://www.cpearson.com/excel/duplicat.htm
  12. 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
  13. 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!
  14. 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
  15. jos työkirja sisältää kaavioita. On mennyt käsitteet Sheet ja Worksheet vähän sekaisin...
    keep Excelling
  16. =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
  17. mutta kokeiles ensiksi esim.
    Range("A1").FormulaLocal= "..."
  18. 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
  19. 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
  20. 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
    21. 63 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt