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. moduuliin...


    Sub LeikkaaJaSirrä()
    'leikkaa rivit 1-10000 uuteen taulukkoon Data1,Data2 jne
    'tiedot oletuksena Taulukossa Sheet1
    Sheets("Sheet1").Activate
    For i = 1 To 10
    Rows("1:10000").Cut
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Data" & i
    ActiveSheet.Paste
    Sheets("Sheet1").Activate
    Rows("1:10000").Delete Shift:=xlUp
    Next
    End Sub
  2. vanhoja yhdistäen ;-)

    moduuliin...

    Sub lajittele()
    Dim solu As Range
    Dim vika As Long
    Dim i As Long
    Dim EiTupla As New Collection
    Dim Löydetty As Range

    On Error GoTo virhe
    Vika = Range("E65536").End(xlUp).Row
    For Each solu In Range("E1:E" & Vika)
    If Not IsEmpty(solu) Then
    EiTupla.Add solu.Value, CStr(solu.Value)
    End If
    Next solu
    Range("F:G") = ""
    Range("F1").Select
    For i = 1 To EiTupla.Count
    ActiveCell = EiTupla(i)
    ActiveCell.Offset(1, 0).Select
    Next
    Columns("F:F").Sort Key1:=Range("F1"), Order1:=xlAscending
    Vika = Range("F65536").End(xlUp).Row
    For Each solu In Range("F1:F" & Vika)
    Set Löydetty = EtsiJaSiirrä(solu)
    solu.Offset(0, 1) = Löydetty.Cells.Count
    Next
    Exit Sub
    virhe:
    Resume Next
    End Sub


    Function EtsiJaSiirrä(Hakuehto As Variant) As Range
    Dim solu As Range
    Dim EkaOsoite As String
    Worksheets("Sheet1").Activate
    With Range("E:E")
    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
    Do
    Set EtsiJaSiirrä = Union(EtsiJaSiirrä, solu)
    Set solu = .FindNext(solu)
    Loop While Not solu Is Nothing And solu.Address EkaOsoite
    End If
    End With
    End Function

    Keep Excelling
    @Kunde
  3. että homma toimii...
    Ko funktio on todella monipuolinen, mutta sehän perustuukin Range- objektiin, mikä on mitä monipuolisin objekti Excelin kirjastossa. Soveltamalla saa aikaiseksi uskomattomia juttuja parin rivin koodilla ...

    Tattista vaan
    Keep Excelling
    @Kunde
  4. 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
  5. 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
  6. 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
  7. kysyttiin samaa asiaa...
    http://keskustelu.suomi24.fi/node/9109932
  8. 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
  9. Sub KopioiToisestaToiseen()
    Workbooks("Koe1").Worksheets("Sheet1").Range("A1").Copy Workbooks("Koe2").Worksheets("Sheet1").Range("A1")
    End Sub

    Keep Excelling ;-)
    @Kunde
  10. 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
  11. moduuliin...
    nyt Sheet1 taulukko oletuksena

    Sub Auto_Open()
    Worksheets("Sheet1").Activate
    ActiveWindow.Zoom = 130
    End Sub
  12. 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
  13. 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?
  14. 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
  15. Kunde ei tajunnut yhtään mitään...
    voisitkos antaa esimerkin
  16. mun koodihan tekee just niin kuin halusit
    SHIFT+CTRL+D
    ;-)
  17. 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
  18. 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
  19. 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
  20. 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
    21. 44 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt