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

634

Äänestä

    Vastaukset 9

    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. Suomalaisten pinna paloi - Ärsytys iskee uudesta TTK-juontajasta "Eihän tälle voi kun nauraa"

      Oliko Veronica Verho hyvä valinta TTK-juontajaksi? Uuden TTK-juontajan henkilöllisyyttä on arvailtu siitä asti, kun Va
      Suomalaiset julkkikset
      110
      2311

    2. Mitä tapahtuu?

      Mitä tapahtuu Humalojalla? Poliiseja talon ympärillä ja paljon ihmisiä pitkin pihoja???
      Haapavesi
      23
      1004

    3. T rakastan sua

      vaikket sitä usko
      Ikävä
      71
      912

    4. Mitäpä luulet että tykkääkö

      kukaan kaivatustasi ?
      Ikävä
      103
      906

    5. Varmaan aika moni

      Haluaisi sinut enemmän kuin mielellään
      Ikävä
      48
      845

    6. Suomi on viittä vaille sodassa Venäjän kanssa...

      ...syynä tähän on kokoomuslainen presidenttimme Stubb. Hän on ainoa eurooppalaisen maan johtaja, joka kärkkäästi ja taha
      Maailman menoa
      570
      845

    7. Miksi et lähesty minua

      Jos kerran kaipaat, mies? Mitä pelkäät?
      Ikävä
      82
      738

    8. Olen vähän epävarma siitä, oletko kiltti

      Nainen, ensivaikutelma oli, että olet tosi hyväsydäminen eli siinä mielessä harvinaisuus. Eli et mene virran mukana, etk
      Ikävä
      76
      670

    9. Kai sä olet

      Luovuttanut mun suhteen.
      Ikävä
      66
      635

    10. Herkkä, hellä, aurinkoinen, kaunis upea, valonsäde on hän nainen

      Ja myös fiksu, älykäs ja luonnonläheinen. Erittäin mielenkiintoinen ja kiltti ihminen. Haluan tuntea hänet, koska kaik
      Ikävä
      30
      627
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt