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

597

Ää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. Jalankulkija kuoli. Poliisi etsii mustaa BMW Coupe -autoa, jossa on punertavat vanteet.

      Jalankulkija kuoli jäätyään auton alle Joensuussa – kuljettaja pakeni, poliisi pyytää havaintoja https://www.mtvuutiset.
      Joensuu
      178
      4090

    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
      27
      3127

    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
      26
      2818

    4. Vassarina hymyilyttää vaurastuminen persujen kustannuksella

      Olen sijottanut määrätietoisesti osan Kelan tuista pörssiosakkeisiin, ja salkku on paisunut jo toiselle sadalle tuhanne
      Maailman menoa
      59
      2711

    5. 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
      55
      2640

    6. Riikka runnoo: Elisalta potkut 400:lle

      Erinomaisen hallitusohjelman tavoite 100 000 työllistä lisää yksityisellä sektorilla on kohta saavutettu. Toivotaan toiv
      Maailman menoa
      90
      2585

    7. 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
      11
      2320

    8. Pääseekö kuka tahansa hoitaja katselemaan kenen tahansa ihmisen terveystietoja?

      "Meeri selaili puhelinta uteliaisuuttaan ja katuu nyt – Moni hoitaja on tehnyt saman rikoksen Tuttujen ihmisten asiat k
      Maailman menoa
      86
      2035

    9. Nainen rakas

      Mulle on alkanut tulla sellainen olo että meistä tulee ehkä pariskunta vielä 😌
      Ikävä
      147
      1939

    10. Niinistö neliraajajarrutteli Natoon liittymistä vielä sodan alettua

      Myöntää nyt itsekin, mikä jo aikaisemmin tiedettiin. Marin vei Suomen ja Ruotsin Natoon. "”Myönnän auliisti jarruttelle
      Maailman menoa
      202
      1847
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt