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

599

Ää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. PÄIVÄN PARAS: Nigerialainen haki turvapaikkaa Suomesta, lähti takas huilaamaan

      kotimaahansa, koska turvapaikan saaminen kesti niin kauan. Ja tämän kertoo ihan Yle, eikä yhtään toimittaja kyseenalaist
      Maailman menoa
      157
      3863

    2. Mikä vasemmistolaisista jankkaavaa vaivaa?

      Pahasti on ihon alle, siis korvien väliin sinne tyhjään tilaan, päässeet kummittelemaan. Ei ole terveen ihmisen merkki
      Maailman menoa
      100
      3661

    3. Ohjelma "Rikollisjengien Ruotsi" hyvin paljasti jakautuneen maan

      eli ns. ruotsalaiset yhdellä puolella, muslimit ja muut kehitysmaalaiset toisella puolella. Siinäkin hyvin näki mitä ma
      Maailman menoa
      42
      3203

    4. Pidennetään viikko 8 päiväiseksi

      Ja jätetään työpäivien määrä nykyiseen 5:een. Tuo olisi kompromissiratkaisu vellovaan keskusteluun työajan lyhentämisest
      Maailman menoa
      18
      2531

    5. Miksi eristäydyt?

      Onko jokin syy kun vetäydyt omiin oloihin?
      Ikävä
      184
      2238

    6. Jos Katja Ståhl ei pääse juontamaan Elämäni biisiä, kenet haluaisit nähdä juontohommissa?

      Katja Ståhl on ollut kuluvalla viikolla sairaalahoidossa. Jos Katja Ståhl ei pääse juontamaan Elämäni biisiä, kenet halu
      Tv-sarjat
      27
      1417

    7. Kuvaile kaivattuasi kolmella emojilla.

      :) 😛😆😱
      Ikävä
      97
      1267

    8. Tiesitkö? Tuure ja Saana Boelius ovat sisaruksia!

      Tiesitkö? Tuure Boelius ja Saana Boelius ovat tänä syksynä kumpainenkin reality-ohjelmissa tv:ssä: Tuure Petollisissa ja
      Suomalaiset julkkikset
      24
      1091

    9. Vähäkankailla ollut ongelmia vuokra-asunnossa

      Aina ne ikävätkin asiat tulevat mediaan. Jasmin ja Marko saaneet edellisestä asunnostaan häädöt ja Jasmin todettu varatt
      Kotimaiset julkkisjuorut
      128
      1088

    10. Jos elämäsi ihminen

      on osoittanut kiinnostuksensa, niin kannattaa vastata edes jotain vaikka mikä olisi. Toista mahdollisuutta ei välttämätt
      Ikävä
      69
      1048
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt