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.
Kopiointi yhdeltä välilehdeltä muille!
9
542
Vastaukset
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? KiitosOption 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 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? Kiitosnyt 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 FunctionHei!
Kiitoskia kun jaksat auttaa, mutta jostian syystä tiedot eivät kopioidu siltä riviltä. 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 FunctionHei!
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?
Kiitostä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ä.
Luetuimmat keskustelut
en vaan saa häntä pois
Mielestäni pyörimästä. Onko kellekään toiselle käynyt näin? Ihastuin pakkomielteisesti noin vuosi sitten erääseen naiseen. Ei vaan katoa mielestä va1751968Suomi24 kysely: ihmisten kuplautumista ei pääosin koeta vakavaksi ongelmaksi
“Kuplautumista on mahdotonta estää. Ihmiset ovat aina viihtyneet samankaltaiset arvot ja maailmankatsomuksen jakavassa seurassa ja muodostaneet sen pe361694Ohhoh! Glamourmalli Elena, 29, teetti tiimalasivartalon - Vei rahaa ja tuotti tuskaa - Katso kuvat!
Transtaustainen glamourmalli Elena Vikström on käynyt vuosien ajan plastiikkakirurgisissa toimenpiteissä. Tästä näet lopputuloksen: https://www.suomi81318Ostiko Martina uuden ponin tyttärelleen, vai oliko myös Stefan itsekkin valitsemassa ponia .?
Kiva kun on tyttärelle mielekäs harrastus annettu, ehkä vielä on tulevaisuudessa hänelle tärkeä ja valitsee sen perusteella tulevan ammatin.2241145Sinä olet tärkeä
Herätät minussa kunnioitusta. Kiehdot minua. En oikein saa kiinni sinusta. Ehkä juuri siksi. Aistin että sinäkin pidät minusta. Vetovoima on ollut alu561142Varisjärvellä mersu.
Varisjärven tiellä tuli vanhamersu kylkiedellä mutkassa vastaan ja vähällä keulaan mutta tökkäs penkkaan, hyppäsin omasta autosta ulos ja kävin kiskas151017- 59925
Belorf haistattaa seuraajiaan "You can hate me now"...
Vai haistattaako lompakkoa, joka taisi viimeinkin ymmärtää häipyä Sofian ulottumattomiin ? Sofia raukka on niin typerä, että ottaa nostetta "omasta tv57909