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. kyllä toi toimii ihan ok, jos excelissä VBA koodia väsäät-jos VB:llä niin sitten eri juttu.

    Private Sub CommandButton1_Click()
    Range("B:B,C:C,D:D,E:E,F:F,H:H,J:J,K:K,L:L").Select
    End Sub


    voit kokeilla lisätä koodiin taulukon aktivoinnin niin silloin ainakin toimii...

    esim.
    Private Sub CommandButton1_Click()
    Worksheets("Sheet1").Activate
    Range("B:B,C:C,D:D,E:E,F:F,H:H,J:J,K:K,L:L").Select
    End Sub
  2. excelin taukukon painikkeeseen koodi

    Private Sub CommandButton1_Click()
    UserForm1.Show
    End Sub

    lisää VBA puolella userform ja siihen komentopainike ja tekstiruutu. Tekstiruudun ominaisuuksissa, Password kohtaan laita haluamasi merkki jota toistetaan normaalistihan se on * ...


    lomakkeelle koodi

    Private Sub CommandButton1_Click()

    If TextBox1 = "passu" Then
    Sheets("1").Visible = True
    Sheets("2").Visible = True
    Sheets("1").Select
    Else
    MsgBox "Password incorrect!"
    Exit Sub
    End If
    End Sub
  3. ei oikein onnaa fiksusti ilman APIa, mutta testailin SendKeys komennoilla kikkailla ja toimii se silläkin ihan jees ;-)


    Excelissä Tools/Macro/Security Trusted Publisher välilehdeltä pitää laittaa ruksi kohtaan Trust Access to Visual Basic Project

    ja originaalissa pitää olla viittaus VBA puolella referenssiin Microsoft Visual Basic for Applications Extensibility 5.3
    moduuliin...

    Sub TallennaSanasanalla()
    päivä = 25
    kuukausi = 11
    vuosi = 2008
    tiedostonimi = "b"
    Sheets(Array("1", "2", "3")).Copy
    With Application

    .VBE.CommandBars("Menu Bar").Controls("Tools") _
    .Controls("VBAProject Properties...").Execute

    .SendKeys "^{TAB}"

    .SendKeys "{ }"

    .SendKeys "{TAB}" & "kunde"

    .SendKeys "{TAB}" & "kunde"

    .SendKeys "{TAB}"

    .SendKeys "{ENTER}"
    End With
    ActiveWorkbook.SaveAs Filename:="C:\" & vuosi & "_" & kuukausi & "_" & päivä & "_" & tiedostonimi & ".xls"
    ActiveWorkbook.Close
    End Sub

    Keep Excelling
    @Kunde
  4. originaalissa valitse haluamasi kuukausi välilehdeltä sarakkeesta A se päivämäärä, jonka rivitiedot haluat siirtää osastojen työkirjoihin

    moduuliin...

    Sub Siirrä()
    Dim Päivä As Integer
    Dim Kuukausi As String
    Dim Vuosi As Integer
    Dim Haku As String
    Dim Myynti As Double
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If ActiveCell = "" Then
    MsgBox "Valitsemasi solu on tyhjä!"
    Exit Sub
    End If
    Päivä = ActiveCell
    'MUUTA TEKSTI JOS TAULUKKO EI OLE NIMETTY TAMMIKUU, HELMIKUU...
    'JOS TAMMI, HELMI... NIIN MUUTA TAMMI, HELMI...
    Select Case UCase(ActiveSheet.Name)
    Case "TAMMIKUU"
    Kuukausi = 1
    Case "HELMIKUU"
    Kuukausi = 2
    Case "MAALISKUU"
    Kuukausi = 3
    Case "HUHTIKUU"
    Kuukausi = 4
    Case "TOUKOKUU"
    Kuukausi = 5
    Case "KESÄKUU"
    Kuukausi = 6
    Case "HEINÄKUU"
    Kuukausi = 7
    Case "ELOKUU"
    Kuukausi = 8
    Case "SYYSKUU"
    Kuukausi = 6
    Case "LOKAKUU"
    Kuukausi = 7
    Case "MARRASKUU"
    Kuukausi = 8
    End Select
    'MUUTA TARVITTAESSA
    Vuosi = 2008

    'MUUTA työkirjojen nimet b,c,d...
    'B SARAKKEEN OSASTO
    Myynti = ActiveCell.Offset(0, 1)
    Haku = Päivä & "." & Kuukausi & "." & Vuosi
    EtsiJaSiirrä Haku, Myynti, "b"


    'C SARAKKEEN OSASTO
    Myynti = ActiveCell.Offset(0, 2)
    Haku = Päivä & "." & Kuukausi & "." & Vuosi
    EtsiJaSiirrä Haku, Myynti, "c"


    'D SARAKKEEN OSASTO
    Myynti = ActiveCell.Offset(0, 3)
    Haku = Päivä & "." & Kuukausi & "." & Vuosi
    EtsiJaSiirrä Haku, Myynti, "d"


    'E SARAKKEEN OSASTO
    Myynti = ActiveCell.Offset(0, 4)
    Haku = Päivä & "." & Kuukausi & "." & Vuosi
    EtsiJaSiirrä Haku, Myynti, "e"


    'F SARAKKEEN OSASTO
    Myynti = ActiveCell.Offset(0, 5)
    Haku = Päivä & "." & Kuukausi & "." & Vuosi
    EtsiJaSiirrä Haku, Myynti, "f"


    'G SARAKKEEN OSASTO
    Myynti = ActiveCell.Offset(0, 6)
    Haku = Päivä & "." & Kuukausi & "." & Vuosi
    EtsiJaSiirrä Haku, Myynti, "g"


    'H SARAKKEEN OSASTO
    Myynti = ActiveCell.Offset(0, 7)
    Haku = Päivä & "." & Kuukausi & "." & Vuosi
    EtsiJaSiirrä Haku, Myynti, "h"


    'I SARAKKEEN OSASTO
    Myynti = ActiveCell.Offset(0, 8)
    Haku = Päivä & "." & Kuukausi & "." & Vuosi
    EtsiJaSiirrä Haku, Myynti, "i"


    'J SARAKKEEN OSASTO
    Myynti = ActiveCell.Offset(0, 9)
    Haku = Päivä & "." & Kuukausi & "." & Vuosi
    EtsiJaSiirrä Haku, Myynti, "j"


    'K SARAKKEEN OSASTO
    Myynti = ActiveCell.Offset(0, 10)
    Haku = Päivä & "." & Kuukausi & "." & Vuosi
    EtsiJaSiirrä Haku, Myynti, "k"


    'L SARAKKEEN OSASTO
    Myynti = ActiveCell.Offset(0, 11)
    Haku = Päivä & "." & Kuukausi & "." & Vuosi
    EtsiJaSiirrä Haku, Myynti, "l"

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

    Function EtsiJaSiirrä(Päiväys As String, Tieto As Double, Osasto As String) As Range
    Dim Solu As Range
    Dim Työkirja As Workbook
    Päiväys = Format(Päiväys, "Short Date")
    On Error Resume Next
    'MUUTA POLKU
    Set wb = Workbooks.Open("C:\Documents and Settings\Kunde\Omat tiedostot\" & Osasto & ".xls", False, False)
    wb.Sheets(1).Activate
    Set Solu = Cells.Find(What:=CDate(Päiväys), After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
    Range(Solu.Address).Offset(0, 1) = Tieto
    On Error GoTo 0
    wb.Close True
    End Function

    Keep Excelling
    @Kunde
  5. http://www.bmsltd.co.uk/Excel/Default.htm
    ja lataa sieltä FormFun.zip
  6. taulukon moduuliin...
    ja solussa A3 =Summa (A1:A2)


    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Range("A4") = "" And Not Range("A1") = "" And Not Range("A2") = "" Then
    Range("A4") = Range("A3")
    End If
    End Sub
  7. moduuliin...

    Function Etsi(Hakuehto As Variant) As Range
    Dim solu As Range
    Dim EkaOsoite As String
    Worksheets("Sheet1").Activate
    With Range("D2:D22")
    Set solu = .Find( _
    What:=Hakuehto, _
    LookIn:=xlValues, _
    LookAt:=xlPart, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, _
    MatchCase:=False, _
    SearchFormat:=False)
    If Not solu Is Nothing Then
    Set Etsi = solu
    EkaOsoite = solu.Address
    Do
    Set Etsi = Union(Etsi, 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
    Dim Haku As Variant

    On Error GoTo virhe
    Haku = "x"
    Set Löydetty = Etsi(Haku)
    MsgBox Union(Löydetty, Löydetty).Address
    Exit Sub
    virhe:
    MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
    End Sub
  8. mun viesteissä tarkoittaa

    taulukon moduuliin...

    taulukon valitsemasta klikkaat hiiren oikealla ja klikkaat Näytä koodi/View Code ja seuraavaksi aukeaa VBA editorissa taulukon moduuli mihin liität koodin tai

    excelin puolella ALT+F11 ja aukeaa VBA editori ja ja vasemmalta VBAProject "työkirjan nimi" tuplaklikkaat taulukon nimeä mihin koodin haluat liittää
    jos VBAProject ikkuna ei ole näkyvissä sen saat näkyviin valikosta View/Project Explorer tai CTRL+R

    moduuliin...
    valikosta Insert/Module ja liität koodin aukeavaan moduuliin

    Class moduuliin...

    valikosta Insert/Class Module ja liität koodin aukeavaan moduuliin

    sun tapauksessa nyt toi eka taulukkokoodi on tavallisessa moduulissa eikä taulukon moduulissa, joten ei voi toimia...

    siirrä se siis sinne taulukon moduuliin
  9. Mulla Excel 2003 ja piippaa ihan kivasti.
    siis taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$A$1" And Target.Value = 0 Then
    PlayWAV
    End If
    End Sub

    ja moduuliin ...

    Private Declare Function PlaySound Lib "winmm.dll" _
    Alias "PlaySoundA" (ByVal lpszName As String, _
    ByVal hModule As Long, ByVal dwFlags As Long) As Long

    Const SND_SYNC = &H0
    Const SND_ASYNC = &H1
    Const SND_FILENAME = &H20000

    Sub PlayWAV()
    WAVFile = "beep.wav"
    WAVFile = ThisWorkbook.Path & "\" & WAVFile
    Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
    End Sub
  10. http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000038800866
  11. koodillakaan.
    Viimeksi muutetun solun merkkien määrän saa esim. tilariville allaolevalla koodinpätkällä

    taulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.StatusBar = Len(Target)
    End Sub
  12. velhon avulla, mutta klikkaamalla objektia suunnittelutilassa aukeaa taulukon moduuli ja siellä esim. jos lisätty komentopainike

    Private Sub CommandButton1_Click()
    End Sub

    lisäämällä nyt sen makron tohon proseduuriin toimii ihan jees (Makro pitää olla hmm?- miten ton nyt sanois oikein, uudessa moduulissa(Insert/Module)- ei siis taulukoiden eikä ThisWorkbook moduuleissa )...

    Private Sub CommandButton1_Click()
    Näytä
    End Sub

    ja moduulissa esim.

    Sub Näytä()
    MsgBox "hei"
    End Sub

    @Kunde
  13. koodin alkuun Application.DisplayAlerts = False
    ja loppuun Application.DisplayAlerts = True

    muista sitten varmistaa, että jos virhe ilmenee niin virheenkorjauksessa asetat
    Application.DisplayAlerts = True tai jos ei ole mitään virheen tsekkausta, niin ainakin alkuun laitat sitten On Error Resume Next
  14. ei toimi ei toimi kun taulukko on piilotettu. Tietenkin voit koodilla laittaa sen näkyville ennen kopiointia ja sitten piilottaa kun tarvittavat jutut tehty

    esim.

    Application.ScreenUpdating = False
    Sheets("Data").Visible = xlSheetVisible
    Sheets("Data").Select
    'koodia
    Sheets("Data").Visible = xlSheetVeryHidden
    Application.ScreenUpdating = True

    mutta...
    toimii se näinkin ilman kikkailuja ;-)

    Sheets("Data").Range("A1:A10").Copy Destination:=Sheet2.Range("A1")

    @Kunde
  15. moduuliin...
    tiedot nyt A1:B jotakin
    tulos näkyviin F1 alkaen

    Sub PoistaTuplat()
    Dim cell As Range
    Dim Vika As Double
    Dim EiTupla As New Collection
    On Error GoTo virhe

    Vika = Range("A65536").End(xlUp).Row

    'kopioidaan tiedot F1 alkaen
    Columns("F:G").Clear
    Range("A1:B" & Vika).Copy Destination:=Range("F2")

    'lajitellaan
    Range("F2:G" & Vika).Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("G2") _
    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
    :=xlSortNormal

    'lisätään uniikit arvot kokoelmaan
    For Each cell In Range("F2:F" & Vika + 1)
    If Not IsEmpty(cell) Then
    EiTupla.Add cell.Value, CStr(cell.Value & cell.Offset(0, 1).Value)
    End If
    Next cell
    'tyhjennetään alue ja lisätään riviotsikot
    Columns("F:G").Clear
    Range("F1") = "TULOKSET"
    Range("G1") = "MÄÄRÄ"

    'täytetään tiedot
    'eka kirjain kokoelmasta
    Range("F2").Select
    ActiveCell = EiTupla(1)

    'lisätään loput
    For i = 1 To EiTupla.Count
    If ActiveCell = EiTupla(i) Then
    ActiveCell.Offset(0, 1) = ActiveCell.Offset(0, 1) + 1
    Else
    ActiveCell.Offset(1, 0).Select
    ActiveCell = EiTupla(i)
    ActiveCell.Offset(0, 1) = ActiveCell.Offset(0, 1) + 1
    End If
    Next
    'sarakelevys kohdilleen
    Range("F1:G1").EntireColumn.AutoFit
    Exit Sub
    virhe:
    'tänne tullaan, jos arvo oli jo kokoelmassa... jatketaan vaan lisäystä seuraavilla arvolla
    Resume Next
    End Sub
  16. riippuu mistä valikosta olet sen napin väsännyt... mutta koodilla esim. noin

    objektin nimi.Caption=Range("A1")
  17. suojaa VBA projekti salasanalla ja VBA puolelta pistä Data välilehden visible arvoksi=0 xlSheetHidden. Tällöin ei tartte koodia rukkailla, eli ei tartte Unprotect ja Protect juttujen kanssa painia
    @Kunde
  18. oiskos tosta apua?
    testasin tota ja peruutusten määrää oli helppo muutella

    http://support.microsoft.com/kb/211922
  19. vikana-eli Sort Key1:=ActiveCell jolloin aina lajitellaan aktiivisen solun mukaan
    alla hieman siistittynä(ilman virhetarkasteluja ja N-sarake testiä) sama koodin pätkä

    Sub testi()
    Const NumColums As Integer = 14 '(Makron pitää laska tuosta valinnasta esim. 13 solua oikealle )

    With ActiveCell.Resize(1, NumColums)
    .Sort Key1:=ActiveCell, Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
    DataOption1:=xlSortNormal
    End With
    ActiveCell.Select
    End Sub
  20. Määritä nimi Tu ja laita sille arvoksi =-26
    siinäpä se...
    21. 57 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt