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

592

Ää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. Lavrov suivaantui Stubbille perustellusti.

      Lavrov perusteli suivaantumistaan tosiasioilla Suomen tarinasta sotiemme jälkeen, tutkija Tynkkynen ja pankkihenkilö Sol
      Maailman menoa
      476
      1723

    2. Sukupuolia on vain kaksi- kohukassista tuli kova tuomio perheenisälle oikeudessa.

      https://www.iltalehti.fi/kotimaa/a/4d4db0d9-4dda-4ba6-a699-25d725683ad6 Miten näin normaalista kassissa olevasta tekstis
      Maailman menoa
      378
      1497

    3. Se ei ihan oikeasti vaatisi kuin yhden

      Tekstiviestin... Jos rakastat minua vielä toivoisin että laittaisit minulle viestiä. Rakastatko? Oletko oikeasti niin pe
      Ikävä
      64
      1338

    4. Eronnut Janni Hussi palaa julkisuuteen - Aloittaa uudessa työssä, joka on aivan uusi pesti Suomessa

      Janni Hussi on saanut viime aikoina kohujulkisuutta, kun hänen ja Joel Harkimon avioliitto päättyi eroon kesällä 2025. H
      Suomalaiset julkkikset
      15
      1299

    5. Et saa mua ikinä

      Oma vikasi. Naiselta.
      Ikävä
      100
      905

    6. JM lukkoliike

      Mihin helvetin kuuseen te olette tällä kertaa siirtäneet Lukkoliikkeenne? Sen kerran kun ensimmäisen ja viimesen kerran
      Jämsä
      19
      856

    7. Ketä ikävöit?

      Tuntomerkkejä jos täällä oikeat kohtaavat❤️
      Ikävä
      47
      804

    8. Miten kesäsi meni?

      Oletko tyytyväinen siihen? Oliko kaivattusi mielessäsi? Lähennyitkö vai etäännyitkö hänen kanssaan?
      Ikävä
      65
      736

    9. Helena Ahti-Hallberg uudessa elämäntilanteessa - Paljastaa eläkehaaveestaan Espanjassa: "Mä.."

      Oi, kuulostaa ihanalta eläkepäivillä! Helena Ahti-Hallberg on ostanut kakkoskodin Espanjasta ja hänellä on puolisonsa ka
      Eläke
      7
      722

    10. Pankin avajaiset

      Osuuspankin uuden toimitilan viralliset avajaiset vetävät väkeä. Kyllä oli outo nauhan leikkaus, kun leikkaajat pyllisti
      Kuhmo
      15
      701
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt