Kopiointi yhdeltä välilehdeltä muille!

Kopiomaster!

Hei!

Onko mahdollista muodostaa semmoista makroa, joka osaisi lukea saraketta (D sarakkeessa on viikot esim. 34, 34, 34, 35, 35, 36, 36 ja 37) ja muodostaisi niiden perusteella exceliin tarvittavat välilehdet, nimeäisi välilehdet viikoilla ja kopioisi välilehdille ne rivit, jossa on vastaavat viikot? Tietenkin välilehdet voisi tehdä automaattisesti ja makro vain kopioisi vastaavat rivit välilehdille?
Onko välilehtien määrällä rajoitteita?

Kiitoksia etukäteen.

9

557

Äänestä

    Vastaukset

    Anonyymi (Kirjaudu / Rekisteröidy)
    5000
    • kunde

      taulukoiden rajana koneen muisti...
      tolla nyt pääset alkuun ja sitä on helppo muokkailla itselle sopivaksi

      Option Explicit
      Sub LisääTaulukko()
      Dim Taulukko As Worksheet
      Dim Vika As String
      Dim solu As Range
      On Error Resume Next
      Application.DisplayAlerts = False
      Worksheets("Sheet1").Activate
      Vika = Range("D65536").End(xlUp).Row
      For Each solu In Range("D1:D" & Vika)
      For Each Taulukko In Worksheets
      If Taulukko.Name = solu Then
      Taulukko.Delete
      End If
      Next Taulukko
      solu.EntireRow.Copy
      Sheets.Add.Name = solu
      ActiveSheet.Paste
      Range("A1").Select
      ActiveSheet.Move After:=Sheets(Sheets.Count)
      Next solu
      Application.CutCopyMode = False
      Application.DisplayAlerts = True
      End Sub

      Keep Exceling
      @Kunde

      • mutta kopioi vain ekan tiedon

        Hei!

        Kiitos, kiitos.

        ongelmana on se että kopionti tapahtuu vain ensimmäiselle riville.
        Niitä samoja viikkorivejä on noin 10-15 kpl, mutta nyt kopiointi tapahtuu vain yhdelle riville.
        Välilehdet kyllä tulevat hyvin.

        Saisinko vielä tähän apua? Kiitos

      • ...
        mutta kopioi vain ekan tiedon kirjoitti:

        Hei!

        Kiitos, kiitos.

        ongelmana on se että kopionti tapahtuu vain ensimmäiselle riville.
        Niitä samoja viikkorivejä on noin 10-15 kpl, mutta nyt kopiointi tapahtuu vain yhdelle riville.
        Välilehdet kyllä tulevat hyvin.

        Saisinko vielä tähän apua? Kiitos

        Option Explicit
        Sub LisääTaulukko()
        Dim Taulukko As Worksheet
        Dim Vika As String
        Dim solu As Range
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("Taul1").Activate
        Vika = Range("A65536").End(xlUp).Row
        Range("A1").EntireRow.Select
        For Each solu In Range("A2:A" & Vika 1)
        If solu(0) = solu(0).Offset(1) Then
        Selection.Resize(Selection.Rows.Count 1).Select
        Else
        Selection.Copy
        For Each Taulukko In Worksheets
        If Taulukko.Name = solu(0) Then
        Taulukko.Delete
        Exit For
        End If
        Next Taulukko
        Sheets.Add.Name = solu(0)
        ActiveSheet.Paste
        Range("A1").Select
        ActiveSheet.Move After:=Sheets(Sheets.Count)
        Worksheets("Taul1").Activate
        solu.EntireRow.Select
        End If
        Next solu
        Application.CutCopyMode = False
        Application.DisplayAlerts = True
        End Sub

      • kunde
        mutta kopioi vain ekan tiedon kirjoitti:

        Hei!

        Kiitos, kiitos.

        ongelmana on se että kopionti tapahtuu vain ensimmäiselle riville.
        Niitä samoja viikkorivejä on noin 10-15 kpl, mutta nyt kopiointi tapahtuu vain yhdelle riville.
        Välilehdet kyllä tulevat hyvin.

        Saisinko vielä tähän apua? Kiitos

        nyt ei väliä missä kohtaan sarakkeessa viikot on esim. tyyliin 31,32,31,33,32,31,31,31,32,32,32,34,35 jne.


        Dim EiTupla As New Collection
        Dim Taulukko As Worksheet
        Dim i As Integer
        Dim Löydetty As Range
        Dim Haku As Variant

        Sub LisääTaulukko()
        On Error Resume Next
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False

        Worksheets("Sheet1").Activate
        Vika = Range("D65536").End(xlUp).Row
        For Each solu In Range("D1:D" & Vika)
        If Not IsEmpty(solu) Then
        EiTupla.Add solu.Value, CStr(solu.Value)
        End If
        Next solu
        For i = 1 To EiTupla.Count
        For Each Taulukko In Worksheets
        If Taulukko.Name = EiTupla(i) Then
        Taulukko.Delete
        End If
        Next Taulukko
        Sheets.Add.Name = EiTupla(i)
        ActiveSheet.Move After:=Sheets(Sheets.Count)
        Haku = EiTupla(i)
        Set Löydetty = EtsiJaSiirrä(Haku, Range("Sheet1!D1:D" & Vika)).EntireRow
        Union(Löydetty, Löydetty).Copy Range(Haku & "!A65536").End(xlUp).Offset(1, 0).EntireRow

        Next
        Application.CutCopyMode = False
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        End Sub

        Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range
        Dim solu As Range
        Dim EkaOsoite As String
        Worksheets("Sheet1").Activate
        With HakuAlue
        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

      • mutta tiedot eivät kopioidu!
        kunde kirjoitti:

        nyt ei väliä missä kohtaan sarakkeessa viikot on esim. tyyliin 31,32,31,33,32,31,31,31,32,32,32,34,35 jne.


        Dim EiTupla As New Collection
        Dim Taulukko As Worksheet
        Dim i As Integer
        Dim Löydetty As Range
        Dim Haku As Variant

        Sub LisääTaulukko()
        On Error Resume Next
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False

        Worksheets("Sheet1").Activate
        Vika = Range("D65536").End(xlUp).Row
        For Each solu In Range("D1:D" & Vika)
        If Not IsEmpty(solu) Then
        EiTupla.Add solu.Value, CStr(solu.Value)
        End If
        Next solu
        For i = 1 To EiTupla.Count
        For Each Taulukko In Worksheets
        If Taulukko.Name = EiTupla(i) Then
        Taulukko.Delete
        End If
        Next Taulukko
        Sheets.Add.Name = EiTupla(i)
        ActiveSheet.Move After:=Sheets(Sheets.Count)
        Haku = EiTupla(i)
        Set Löydetty = EtsiJaSiirrä(Haku, Range("Sheet1!D1:D" & Vika)).EntireRow
        Union(Löydetty, Löydetty).Copy Range(Haku & "!A65536").End(xlUp).Offset(1, 0).EntireRow

        Next
        Application.CutCopyMode = False
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        End Sub

        Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range
        Dim solu As Range
        Dim EkaOsoite As String
        Worksheets("Sheet1").Activate
        With HakuAlue
        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

        Hei!

        Kiitoskia kun jaksat auttaa, mutta jostian syystä tiedot eivät kopioidu siltä riviltä.

      • kunde
        mutta tiedot eivät kopioidu! kirjoitti:

        Hei!

        Kiitoskia kun jaksat auttaa, mutta jostian syystä tiedot eivät kopioidu siltä riviltä.

        onhan sulla nyt varmasti haettavat viikot sarakkeessa D?

      • wanabee guru
        kunde kirjoitti:

        nyt ei väliä missä kohtaan sarakkeessa viikot on esim. tyyliin 31,32,31,33,32,31,31,31,32,32,32,34,35 jne.


        Dim EiTupla As New Collection
        Dim Taulukko As Worksheet
        Dim i As Integer
        Dim Löydetty As Range
        Dim Haku As Variant

        Sub LisääTaulukko()
        On Error Resume Next
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False

        Worksheets("Sheet1").Activate
        Vika = Range("D65536").End(xlUp).Row
        For Each solu In Range("D1:D" & Vika)
        If Not IsEmpty(solu) Then
        EiTupla.Add solu.Value, CStr(solu.Value)
        End If
        Next solu
        For i = 1 To EiTupla.Count
        For Each Taulukko In Worksheets
        If Taulukko.Name = EiTupla(i) Then
        Taulukko.Delete
        End If
        Next Taulukko
        Sheets.Add.Name = EiTupla(i)
        ActiveSheet.Move After:=Sheets(Sheets.Count)
        Haku = EiTupla(i)
        Set Löydetty = EtsiJaSiirrä(Haku, Range("Sheet1!D1:D" & Vika)).EntireRow
        Union(Löydetty, Löydetty).Copy Range(Haku & "!A65536").End(xlUp).Offset(1, 0).EntireRow

        Next
        Application.CutCopyMode = False
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        End Sub

        Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range
        Dim solu As Range
        Dim EkaOsoite As String
        Worksheets("Sheet1").Activate
        With HakuAlue
        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

        Hei!

        Tarkemmin kuin yritän niin vba stoppaa seuraavaan riviin : Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range.

        Onko mahdollista saada rajattua haun esim: 400 ensimmäiselle riville?

        Kiitos

      • ...
        wanabee guru kirjoitti:

        Hei!

        Tarkemmin kuin yritän niin vba stoppaa seuraavaan riviin : Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Range.

        Onko mahdollista saada rajattua haun esim: 400 ensimmäiselle riville?

        Kiitos

        tämän tilalle Vika = Range("D65536").End(xlUp).Row
        tämä Vika = 400

    • kuinka sitten makro muutetaan

      Hei!

      Entä jos viikot olisivatkin pelkää tekstiä? esim ihmisten nimiä ja haluankin jaotella työt tekijän mukaan?

    Ketjusta on poistettu 1 sääntöjenvastaista viestiä.

    Takaisin ylös

    Luetuimmat keskustelut

    1. Mikä on kaivattusi etunimi?

      Otsikossa siis on kysymys eriteltynä. Vain oikeat vastaukset hyväksytään.
      Ikävä
      122
      2251

    2. En kestä katsoa

      Sitä miten sinusta on muut kiinnostuneita. Olen kateellinen. Siksi pitäisi lähteä pois
      Ikävä
      102
      1340

    3. Peräti 95 % persujen kannattajista rasisteja

      Kertoo EVA:n teettämä kysely. Pakollista yhdenvertaisuuskoulutusta tarvitsee siis paljon laajempi joukko kuin pelkästää
      Maailman menoa
      314
      1043

    4. Kun viimeksi kohtasitte/näitte

      Mitä olitte tekemässä? Millainen ympäristö oli? Löydetään toisemme...
      Ikävä
      103
      1021

    5. Anna minulle anteeksi

      Anna minulle anteeksi. Minä pyydän.
      Ikävä
      108
      1004

    6. Olet kyllä vaarallisen himokas

      Luova, kaunis, määrätietoinen, pervo, mielenkiintoinen, kovanaama, naisellinen ja erikoinen.
      Ikävä
      85
      906

    7. On minulla suunitelma

      Siitä ei vain tiedä kukaan muu kuin tällä hetkellä minä. Suunnitelma ja varasuunnitelma. Sinun takiasi nainen. Vain s
      Ikävä
      44
      690

    8. Palstan ylivoimaisesti suosituin keskustelunaihe

      Palstan suosituin keskustelunaihe näyttää olevan homoseksuaalisuus. Otsikoiden perusteella voisi kuvitella olevansa Seks
      Luterilaisuus
      251
      686

    9. Mikä elokuva kuvaa ikävöityä henkilöä ja sinua?

      Otsikossa aloitus.
      Ikävä
      50
      664

    10. Ei koskaan saatu tuntea

      Mitä olisi ollut painautua toisiimme vasten. Hengittää syvään, hyväillä ja rakastella vailla kiirettä. Tai repiä vaattee
      Ikävä
      33
      660
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt