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. en ollut varma halusitko siirtää vain A-sarakkeen vaiko sarakkeiden A-N tiedot, joten fiksasin molemmat...


    Option Explicit
    Function EtsiJaSiirrä(Hakuehto As Variant) As Range
    'etsii Sheet1 sarakkeesta A ja siirtää Sheet2 sarakkeeseen O
    'oletuksena, että siirrettävät tiedot sarakkeissa A-N
    Dim solu As Range
    Dim solulaajennus As Range
    Dim EkaOsoite As String
    Worksheets("Sheet1").Activate
    With Range("A:A")
    Set solu = .Find( _
    What:=Hakuehto, _
    LookIn:=xlValues, _
    LookAt:=xlWhole, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, _
    MatchCase:=False, _
    SearchFormat:=False)
    If Not solu Is Nothing Then
    Set EtsiJaSiirrä = solu
    EkaOsoite = solu.Address
    Set solulaajennus = solu.Resize(1, 14)
    Do
    Set EtsiJaSiirrä = Union(EtsiJaSiirrä, solulaajennus)
    Set solu = .FindNext(solu)
    Set solulaajennus = solu.Resize(1, 14)
    Loop While Not solu Is Nothing And solu.Address EkaOsoite
    End If
    End With
    End Function

    Sub Testi()
    Dim Löydetty As Range
    Dim alue As Areas
    Dim Alueetlkm As Integer
    Dim i As Integer
    Dim Ylärivi As Long
    Dim Vasensarake As Long
    Dim YläVasen As Range
    Dim KopioitavatAlueet() As Range

    On Error GoTo virhe
    Range("Sheet2!O:AB") = ""
    Set Löydetty = EtsiJaSiirrä(11)
    Alueetlkm = Löydetty.Areas.Count
    ReDim KopioitavatAlueet(1 To Alueetlkm)
    For i = 1 To Alueetlkm
    Löydetty.Areas(i).Copy Range("Sheet2!O65536").End(xlUp).Offset(1, 0)
    Next
    Exit Sub
    virhe:
    MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
    End Sub

    Function EtsiJaSiirrä2(Hakuehto As Variant) As Range
    'etsii Sheet1 sarakkeesta A ja siirtää Sheet2 sarakkeeseen O
    'oletuksena, että haettavat tiedot vain sarakkeessa A
    Dim solu As Range
    Dim EkaOsoite As String
    Worksheets("Sheet1").Activate
    With Range("A:A")
    Set solu = .Find( _
    What:=Hakuehto, _
    LookIn:=xlValues, _
    LookAt:=xlWhole, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, _
    MatchCase:=False, _
    SearchFormat:=False)
    If Not solu Is Nothing Then
    Set EtsiJaSiirrä2 = solu
    EkaOsoite = solu.Address
    Do
    Set EtsiJaSiirrä2 = Union(EtsiJaSiirrä2, solu)
    Set solu = .FindNext(solu)
    Loop While Not solu Is Nothing And solu.Address EkaOsoite
    End If
    End With
    End Function

    Sub Testi2()
    Dim Löydetty As Range
    On Error GoTo virhe
    Set Löydetty = EtsiJaSiirrä2(11)
    Range("Sheet2!O:O") = ""
    Löydetty.Copy Range("Sheet2!O65536").End(xlUp).Offset(1, 0)
    Exit Sub
    virhe:
    MsgBox "hakuehdoilla ei löytynyt tietoja!", vbInformation
    End Sub
  2. Sub Luokittele()
    Dim vika As Long
    Dim solu As Range
    vika = Range("B65536").End(xlUp).Row
    For Each solu In Range("B1:B" & vika)
    Select Case solu
    Case Is > 2000
    solu.Offset(0, 1) = "yli 2000"
    Case Is >= 1900
    solu.Offset(0, 1) = "1900-2000"
    Case Is >= 1800
    solu.Offset(0, 1) = "1800-1900"
    'jne
    Case Else
    solu.Offset(0, 1) = "ei tietoa"
    End Select
    Next
    End Sub
  3. ilman koodia ei onnistu...

    pikku kikkailulla

    taulukon moduuliin...
    nyt solussa H1 kelpoisuustarkistus ja kelpoisuusluettelo on soluissa E1:EXXX
    voi vapaasti poistella arvoja listasta tai lisätä uusia listaan ja jättää jopa tyhjiä soluja väliin. Kun valitaan H1, niin poistaaaluksi tyhjät luettelosta ja päivittää kelpoisuusehdon H1 soluun.
    Helppo lisätä uusia kelpoisuusehto soluja ja muokata koodia lueetelon suhteen

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim vika As Long
    If Not Intersect(Target, Range("H1")) Is Nothing Then
    vika = Range("E65536").End(xlUp).Row
    Range("E1" & vika).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    vika = Range("E65536").End(xlUp).Row
    With Range("H1").Validation
    .Delete
    .Add Type:=xlValidateList, Formula1:="=$E$1:$E$" & vika
    End With
    End If
    End Sub

    Keep Excelling
    @Kunde
  4. kysyttiin samaa asiaa...
    http://keskustelu.suomi24.fi/node/9109932
  5. luulin, että osaat soveltaa...
    koodi pitää olla samalla rivillä, nyt heittää se n tässä 2 riville...

    Sub KopioiToisestaToiseen()
    Workbooks("Koe1").Worksheets("Sheet1").Range("A1").EntireRow.Copy Workbooks("Koe2").Worksheets("Sheet1").Range("A1")
    End Sub
  6. Sub KopioiToisestaToiseen()
    Workbooks("Koe1").Worksheets("Sheet1").Range("A1").Copy Workbooks("Koe2").Worksheets("Sheet1").Range("A1")
    End Sub

    Keep Excelling ;-)
    @Kunde
  7. turhat luupit ja jossittelut pois...
    Sub RunRun
    Dim Taulukko as WorkSheet
    For Each Taulukko In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
    Taulukko.Activate
    Laske
    Next
    End Sub
  8. moduuliin...
    nyt Sheet1 taulukko oletuksena

    Sub Auto_Open()
    Worksheets("Sheet1").Activate
    ActiveWindow.Zoom = 130
    End Sub
  9. taulukon moduuliin...
    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Not Intersect(Target, Range("A1")) Is Nothing Then
    ActiveSheet.Name = Range("A1")
    End If
    End Sub
  10. viittaisi siihen, että taulukko ei ole aktiivinen
    tai taulukko on suojattu
    tai solu lukittu.
    Voisiko olla yhdistetty solu?
    välttämättä koodissa ei tartte valita eikä aktivoida mitään jos tehdään esi. laskutoimituksia yms. soluille tai solualueelle
    Mikä on edellinen koodi makrossa , joka aktivoi taulukon.?
    Toimiiko ko. makro jossain toisessa työkirjassa - avaa uusi työkirja ja kokeile koodia.

    Kyllä toi koodisi pitäisi toimia...
    kokeile seuraavia variaatioita

    Sheets("Sheet1"). Activate
    Range("A1").Select

    tai
    Sheets("Sheet1"). Activate
    Sheets("Sheet1").Range("A1").Select

    tai
    Application.GoTo Sheets("Sheet1").Range("A1")

    toimiiko noilla?
  11. taulukon moduuliin...
    muuta kuvien polku ja tiedostotyyppi sekä kuvan koko sopivaksi
    nyt lisää kuvat sarakkeen A soluihin

    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
    If Not Target.Comment Is Nothing Then
    Target.Comment.Delete
    End If
    Target.AddComment
    Target.Comment.Shape.Fill.UserPicture "C:\" & Target & ".jpg"
    Target.Comment.Shape.Height = 200
    Target.Comment.Shape.Width = 200
    End If
    End Sub
  12. Kunde ei tajunnut yhtään mitään...
    voisitkos antaa esimerkin
  13. mun koodihan tekee just niin kuin halusit
    SHIFT+CTRL+D
    ;-)
  14. oikea koodi- noi select rivit oli vain testejä varten...

    Dim Alkusolut As Range
    Dim Täyttöalue As Range
    Set Alkusolut = Range(ActiveCell, ActiveCell.Offset(-1, 0))
    Set Täyttöalue = Range(ActiveCell, ActiveCell.Offset(9, 0))
    Alkusolut.AutoFill Destination:=Täyttöalue
    End Sub
  15. moduuliin...

    Sub Automaattitäyttö()
    'alkusolut = solut, joissaa on sarjantekoon tarvittavat tiedot eli aktiivinen solu ja sitä edeltävä solu ylöspäin
    'voi olla myös vasemallla ,oikealla ylhäällä- pitää muuttaa offsetteja
    'ActiveCell.Offset(9, 0)) nyt 10 solun sarja alaspäin- muuta lukua tarvittaessa
    'liitä maro pikanäppäimeen TOOLS/MACRO/MACROS/OPTIONS ja liitä kirjain pikanäppäinyhdistelmaan SHIFT+CTRL+D
    Dim Alkusolut As Range
    Dim Täyttöalue As Range
    Set Alkusolut = Range(ActiveCell, ActiveCell.Offset(-1, 0))
    Alkusolut.Select
    Set Täyttöalue = Range(ActiveCell, ActiveCell.Offset(9, 0))
    Täyttöalue.Select
    Alkusolut.AutoFill Destination:=Täyttöalue
    End Sub
  16. taulukon moduuliin...
    muuttele sopivaksi

    Private Sub Worksheet_Change(ByVal Target As Range)
    'Sheet1 on projektipohja
    'solu A1=projektin nimi
    'kopioi ennen koontitaulukkoa(Koonti) pohjan ja nimeää sen solun A1 mukaan
    'tyhjentää koonti taulukossa A-sarakkeen ja täyttää tiedot projektien solusta A2 allekkain
    'tyhjentää projektin nimen ja aktivoi projektinimi solun
    Dim vastaus As Long
    Dim lkm As Long
    On Error GoTo virhe
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    If Not Intersect(Target, Range("A1")) Is Nothing Then
    Worksheets("Sheet1").Copy Sheets(Sheets.Count)
    ActiveSheet.Name = Range("Sheet1!A1")
    End If

    poistu:
    Worksheets("Koonti").Range("A:A") = ""
    For lkm = 2 To Worksheets.Count - 1
    Worksheets(lkm).Range("A2").Copy Worksheets("Koonti").Range("A65536").End(xlUp).Offset(1, 0)
    Next
    Worksheets("Sheet1").Activate
    Range("A1") = ""
    Range("A1").Select
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Exit Sub

    virhe:
    MsgBox "Samanniminen projekti oln jo olemassa!"
    Worksheets(Worksheets.Count - 1).Delete
    GoTo poistu
    End Sub
  17. sama offseteilla

    Sub Siirrä()
    Range("A1,A3,A5").Copy Worksheets("Sheet2").Range("IV1").End(xlToLeft).Offset(0, 1)
    Range("A1,A3,A5") = ""
    End Sub

    Sub Siirrä2()
    Selection.Copy Worksheets("Sheet2").Range("IV1").End(xlToLeft).Offset(0, 1)
    Selection = ""
    Range("A1").Select
    End Sub
  18. pari tapaa...

    hard codella...

    Sub Siirrä()
    Range("A1,A3,A5").Copy Worksheets("Sheet2").Range("IV1").End(xlToLeft)(1, 2)
    Range("A1,A3,A5") = ""
    End Sub

    valitset solut hiirellä ...

    Sub Siirrä2()
    Selection.Copy Worksheets("Sheet2").Range("IV1").End(xlToLeft)(1, 2)
    Selection = ""
    Range("A1").Select
    End Sub
  19. solumuotoiluksi
    kokonaisluvuille 0;-0;;@
    2 desimaalia esim. hinnoille 0,00;-0,00;;@
  20. neuvotaas välillä vähemmän käytettyä NIMI muutujaa.
    Eli lisätään nimi Tuote, jota voidaan sitten käyttää kaavoissa. Nimen käytön etuna mm. ettei tarvitse suojata soluja ja sen voi piilottaa käytäjältä ja siihen voi liittää kaavoja ja kaavoista tulee paljon selkokielisempiä lukea yms. Nyt kuitenkin jätin sen näkyville nimilistassa.

    eli solussa käytät vain nimeä esim. = tuote*1,22 +30
    tai esim ALV hinnan saat suoraan tekemällä nimen Loppuhinta ja viittaukseen laitat =tuote*1,22 ja sitten solussa kaavana =Loppuhinta joka vastaa siis kaavaa = tuote*1,22
    ...

    kaikki muuten kuin kuten Paavali neuvoi (kelpoisuusehto), ja se solumuotoilukin toimii ihan OK, koska siinä on piilotettuna kaikki muut paitsi teksti, joka korvataan" valitse tästä" tekstillä

    TAULUKON moduuliin...

    eli jos solun B2 teksti muuttuu, niin muuttaa Tuotteen hintaa solutekstin mukaisesti. Muuta tuotenimet sopivksi ja lisää tarvittaessa ja muuta tuotenimet hinnat sopivaksi. Muista jos lisäät tuotteita koodiin niin lisää myös kelpoisuusehto luetteloon kanssa
    jos haluat useampaan soluun tuotteita kopioi koodi ja muuta soluosoite (B2) ja muuta nimi muuttujan nimi esim. tuote1 jne

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B2")) Is Nothing Then
    Select Case Target
    Case "Tuoli"
    ActiveWorkbook.Names.Add Name:="Tuote", RefersToR1C1:="=30"
    Case "Pöytä"
    ActiveWorkbook.Names.Add Name:="Tuote", RefersToR1C1:="=130"
    Case "Penkki"
    ActiveWorkbook.Names.Add Name:="Tuote", RefersToR1C1:="=80"
    Case "Kaappi"
    ActiveWorkbook.Names.Add Name:="Tuote", RefersToR1C1:="=400"
    Case "Sänky"
    ActiveWorkbook.Names.Add Name:="Tuote", RefersToR1C1:="=800"
    End Select
    End If
    End Sub
    21. 44 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt