Lijst automatisch invullen en wegschrijven als tab met naam

[peter59]

Hallo,

Het is de bedoeling om d.m.v. een macro een lijst (tab Invullijst in de bijlage) in te vullen a.d.h.v. een gegevenslijst (tab Gegevens in de bijlage).
Tab Jos is zoals het dient te worden.

Maar nu komt het.
Is het mogelijk om voor iedere naam in kolom A een nieuw tabblad te verkrijgen met als tabnaam de naam corresponderend uit kolom O?
De gegevenslijst kan uit wel +/- 250 namen bestaan dus ook zoveel tabs.

Of is er misschien een andere oplossing/suggestie?

Ik sta voor alles open.

Ik wil jullie nu al danken voor het meedenken.

Mvg
Peter

 

[Quiby]

Ik heb een opzet gemaakt, waarbij voor de 5 namen een tabblad wordt gemaakt met de naam die in kolom O staat. Is dit hoe je het bedoelt?
Of bedoel je juist dat de invullijst ingevuld dient te worden en dat dit automatisch een nieuwe tabblad wordt en dit bij de gegevens ingevoerd dient te worden?



Het nadeel van de macro nu is dat een tabblad een unieke naam moet hebben. Er kan dus niet 2 keer een tabblad Jos aangemaakt worden.

 

[peter59]

Hallo Quiby

Allereerst dank voor het meedenken.

Ik heb een opzet gemaakt, waarbij voor de 5 namen een tabblad wordt gemaakt met de naam die in kolom O staat. Is dit hoe je het bedoelt?
Dat is idd wat ik bedoel.
Ik heb de code ook eens proberen te ontrafelen maar bij +/- 250 namen wordt dit een hele lange code.

Het nadeel van de macro nu is dat een tabblad een unieke naam moet hebben. Er kan dus niet 2 keer een tabblad Jos aangemaakt worden.
Hier heb je volledig gelijk in.
Is dit misschien te ondervangen met de naam uit kolom O gecombineerd met naam uit kolom A?
Maar dat wordt mijn inziens de code nog veel langer en misschien traag.

Mvg
Peter

 

[Quiby]

Hallo Peter

Ik heb een opzet gemaakt, waarbij voor de 5 namen een tabblad wordt gemaakt met de naam die in kolom O staat. Is dit hoe je het bedoelt?
Dat is idd wat ik bedoel.
Ik heb de code ook eens proberen te ontrafelen maar bij +/- 250 namen wordt dit een hele lange code.
De code zal niet langer worden. Er zit namelijk een loop in de code waardoor hij de code steeds herhaalt. Wat je verder in de code ziet staan is alleen maar om de gegevens in te vullen. Het is wel zo naarmate er meer tabbladen toegevoegd dienen te worden duurt het wat langer om hem uit te voeren.

Het nadeel van de macro nu is dat een tabblad een unieke naam moet hebben. Er kan dus niet 2 keer een tabblad Jos aangemaakt worden.
Hier heb je volledig gelijk in.
Is dit misschien te ondervangen met de naam uit kolom O gecombineerd met naam uit kolom A?
Maar dat wordt mijn inziens de code nog veel langer en misschien traag.
Een combinatie is natuurlijk ook mogelijk en wordt de code ook niet echt groter van. Dit heb ik gedaan bij de knop "tabblad toevoegen 1"
Zelf dacht ik om eventueel een nummer te zetten achter de naam in kolom. Dit heb ik gedaan bij de knop "tabblad toevoegen 2" Vervolgens zou je de tabblad nog kunnen sorteren http://www.helpmij.nl/forum/showthread.php/411812-Tabbladen-sorteren-dmv-VBA


Nog een andere opmerking.
De macro's zouden voor alle rijen een nieuw tabblad maken, ook voor de rijen waarvan al een tabblad bestond.
Nu heb ik dat opgelost door in cel AB2 neer te zetten tot welke rij al een tabblad van gemaakt is. Zolang er dan geen rijen tussenuit verwijderd worden zou dit geen problemen geven.

Bekijk bijlage Test invulsheet Q.xlsb

 

[VenA]

Voor het invoeren van de gegevens kan je het beste een Userform gebruiken. Je hebt in het voorbeeld bestandje de gegevens al netjes in in 'tabel' staan. Dit ga je natuurlijk nooit meer opsplitsen naar verschillende tabjes. Lijkt mij een leuke speurtocht om in ± 250 tabjes wat te vinden. Het lijkt erop dat je een bon wil printen. Dit kan je ook realiseren met een dubbelklik in een regel in de 'tabel' in de tab 'Gegevens'

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Cells(1).CurrentRegion) Is Nothing And Target.Row > 1 Then
    With Target
        ar = Array(Cells(.Row, 1).Value, Cells(.Row, 14).Value, Cells(.Row, 9).Value, Cells(.Row, 8).Value, Cells(.Row, 4).Value, Cells(.Row, 5).Value)
    End With
    With Sheets("Printbon")
        .[C8].Resize(6) = Application.Transpose(ar)
        .[B31] = Cells(Target.Row, 15)
        .PrintPreview
    End With
End If
Cancel = True
End Sub

 

[peter59]

Hallo,

@VenA
Dank voor het meedenken.
Jouw code toegepast en hij maakt bij dubbelklikken in een cel een complete printpreview.
En dat is helaas niet de bedoeling.

@Quiby
Wederom dank voor je inbreng.
Ik ga met jouw 1ste versie verder stoeien.
Voor het e.e.a. identiek te krijgen betreffende de namen van tabbladen ga ik d.m.v. de macrorecoder oplossen.
(invoegen hulpkolommen>>samenvoegen>> kopiëren/plakken>>hulpkolommen verwijderen)


Tot dusver dank voor jullie support.
Misschien krijgt dit draadje nog een vervolg.

Mvg
Peter

 

[VenA]

Ik zag dat ik een verkeerd bestandje had geplaatst in #5. De code heb je blijkbaar op jouw eigen bestand losgelaten wat een goed idee was.:d De .PrintPreview kan je natuurlijk weglaten. Mij ontgaat nog steeds het doel om de gegevens in ± 250 verschillende tabjes te zetten.

 

[peter59]

Hallo VenA

De code heb ik idd los gelaten op het origineel.

Kort door de bocht is het de bedoeling van die +/- 250 tabbladen om de gegevens per rij in een format te krijgen en deze per gesorteerd tabblad, per leidinggever te versturen per mail.
Maar zover ben ik nog lang niet.

Misschien andere suggesties?

Mvg
Peter

 

[VenA]

Dan was mijn gedachte zo gek nog niet. In plaats van een afdrukvoorbeeld kan je de gegevens natuurlijk ook mailen!

De code heb ik bewust wat 'ruimtelijk' opgezet zodat je misschien ziet wat er zoal kan.

Er zitten twee aannames in: Je verstuurt het als een .xlsx en je maakt gebruik van MS-Outlook. Het hele proces van wat wanneer verstuurd moet worden is mij niet duidelijk dus de code maar even onder het dubbelklik event gelaten.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim c00 As String, c01 As String, c02 As String, ar
c00 = "D:\VenA\"
If Not Intersect(Target, Cells(1).CurrentRegion) Is Nothing And Target.Row > 1 Then

    With Target
        ar = Array(Cells(.Row, 1).Value, Cells(.Row, 14).Value, Cells(.Row, 9).Value, Cells(.Row, 8).Value, Cells(.Row, 4).Value, Cells(.Row, 5).Value)
        c00 = c00 & Cells(.Row, 4) & "_" & Format(Now, "yyyymmdd_hhmm") & ".xlsx"
        c01 = Cells(.Row, 24).Value
        c02 = "Hallo " & Cells(.Row, 15) & Chr(10) & Chr(10) & "In de bijlage de gegevens van: " & Cells(.Row, 4) & " " & Cells(.Row, 1)
    End With
    
    With Sheets("Printbon")
        .[C8].Resize(6) = Application.Transpose(ar)
        .[B31] = Cells(Target.Row, 15)
        .Copy
    End With
    
    With ActiveWorkbook
        .SaveAs c00, 51
        .Close 0
    End With
    
    With CreateObject("Outlook.Application").CreateItem(0)
        .to = c01
        .Subject = "Weer een nieuwe!"
        .body = c02
        .attachments.Add c00
        .display
    End With
    
End If
Cancel = True
End Sub

Waarom gebruik je zo'n groot bereik?

Sub VenA()
MsgBox Blad2.UsedRange.Address
End Sub

 

[HSV]

Als je van niet teveel schrijfwerk houdt.

ar = application.index(rows(.row),1,array(1,14,9,8,4,5))

 

[peter59]

Hallo,

@VenA
Mijn eerste indruk is gewoon overweldigend.
Je slaat de spijker geheel op de kop.
Is je code te verbinden aan een knop? Zodat de code alle rijen naloopt?

Je stelt ook de vraag waarom ik een zo'n groot bereik gebruik.
Die vraag begrijp ik niet zo goed. Je geeft een stukje code. Waar dien ik die toe te voegen?

@HSV
Dank voor het meedenken.
Ik ben tot nu toe blij met een langere code.
Ik kan deze dan "makkelijker" herleiden. Oftewel een hééééél klein beetje vertalen.
Om toch het e.e.a. te leren is mijn vraag. Waar dient jouw code geplaats te worden en wat doet deze eigenlijk?


Nogmaals heel hartelijk dank.
Ik ga er verder mee stoeien (weekend) en dit draadje wordt gegarandeerd vervolgt.

Mvg
Peter

 

[VenA]

Als je niet weet hoe of waar je code moet toepassen/aanpassen dan ben ik benieuwd of je dit aan de praat krijgt.

Sub VenA()
Dim c00 As String, ar
c00 = "D:\VenA\"
ar = Blad2.Cells(1).CurrentRegion
For j = 2 To UBound(ar)
    With Sheets("Printbon")
        .[C8].Resize(6) = Application.Transpose(Array(ar(j, 1), ar(j, 14), ar(j, 9), ar(j, 8), ar(j, 4), ar(j, 5)))
        .[B31] = ar(j, 15)
        .Copy
    End With
    With ActiveWorkbook
        .SaveAs c00 & ar(j, 4) & "_" & Format(Now, "yyyymmdd_hhmm") & ".xlsx"
        .Close 0
    End With
    With CreateObject("Outlook.Application").CreateItem(0)
        .to = ar(j, 24)
        .Subject = "Weer een nieuwe!"
        .body = "Hallo " & ar(j, 15) & Chr(10) & Chr(10) & "In de bijlage de gegevens van: " & ar(j, 4) & " " & ar(j, 1)
        .attachments.Add c00 & ar(j, 4) & "_" & Format(Now, "yyyymmdd_hhmm") & ".xlsx"
        .display '.send
    End With
Next j
End Sub

Met het grote bereik bedoel ik $A$1:$XFA$751

Om de code van HSV te begrijpen zal je even wat moeten lezen over de excelfunctie INDEX()

@HSV

Als je van niet teveel schrijfwerk houdt.

Copy/Paste De meeste tijd zit in dit soort bestanden toch in het uitzoeken van wat waar vandaan komt. Maar wel weer een mooie om te onthouden.

 

[peter59]

VenA,

Wederom dank voor de geboden hulp.

Ik ga mijn best doen om de code zoals ik hem in gedachte heb, aan de praat te krijgen.
Jouw code heb ik in het origineel al aan de praat.
Ik ga dit weekend (als er niets onverhoopt tussen komt) het e.e.a. proberen en laat je (jullie) het brouwsels zien.

Mvg
Peter

 

[peter59]

Hallo,

Belofte maak schuld.

Onderstaand voorbeeld is met hints van Quiby.
Er zijn div. buttons gebruikt maar dit kan natuurlijk ook onder 1 button gehangen worden.
Dus kan veel mooier.
Tevens is er ook een macro in verwerkt om de div. tabbladen op naam te sorteren .
Bekijk bijlage Voorbeeld met hints Quiby.rar

Nu een voorbeeldje met de gegevens verwerkt van VenA met de DoubleClick marcro.
Geheel bestandje behoorlijk moeten "uitkleden" anders was het te groot. Format is gelijk gebleven.
Deze werkt perfect als men maar enkele tabbladen hoeft te verzenden.
Bekijk bijlage Voorbeeld met DoubleClick VenA.rar

Nog een voorbeeldje met gegevens verwerkt van VenA.
Nu met een button om het geheel op te slaan en te verzenden.
Ook dit bestandje behoorlijk moeten "uitkleden". Ook hier is het format gelijk gebleven.
Deze werkt ook perfect. Nadeel is dat in mijn origineel sommige ontvangers wel 50 mails krijgen met in iedere mail 1 document.
Ik ben op de site van Ron de Bruin (http://www.rondebruin.nl/win/s1/outlook/mail.htm) eens aan het snuffelen of per ontvanger meerdere tabbladen als bijlage kunnen worden verzonden.
Bekijk bijlage Voorbeeld met Knop verzenden mail VenA.rar

Zo zie je maar weer dat de mogelijkheden bijna onuitputtelijk zijn oftewel zijn er vele wegen die naar Rome leiden.

Mvg
Peter

 

[VenA]

Het lijkt mij voor andere vraagstellers niet echt handig om .rar bestanden met niet werkende code te plaatsen!

ar = Blad2.Cells(1).CurrentRegion

gaat natuurlijk nooit werken met al die lege kolommen. Als je meerdere bestanden naar één contactpersoon wilt mailen dan moet je de bestanden eerst genereren en vervolgens obv een lijst met contactpersonen de bijlage(n) toevoegen.

Sub VenA()
Dim c00 As String, j As Long, jj As Long, ar, ar1, ar2
c00 = "D:\VenA\"
ar = Blad2.Cells(1).CurrentRegion.Resize(, 15)
Application.ScreenUpdating = False
For j = 2 To UBound(ar)
    With Sheets("Invullijst")
        .[C8].Resize(7) = Application.Transpose(Array(ar(j, 1), ar(j, 14), ar(j, 9), ar(j, 8), ar(j, 4), ar(j, 5), ar(j, 11)))
        .[B32] = ar(j, 15)
        .Copy
    End With
    With ActiveWorkbook
        .SaveAs c00 & "Invullijst voor" & " " & ar(j, 15) & " " & "betreffende" & " " & ar(j, 1) & ".xlsx"
        .Close 0
    End With
Next j

ar1 = Sheets("Contactpersonen").ListObjects(1).DataBodyRange.Resize(, 4)
ar2 = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir " & c00 & "*.xlsx /b/s").StdOut.ReadAll, vbCrLf)
For j = 1 To UBound(ar1)
    For jj = 0 To UBound(ar2) - 1
        If ar1(j, 1) = Split(ar2(jj))(2) Then
            ar1(j, 3) = ar1(j, 3) & "|" & ar2(jj)
            ar1(j, 4) = ar1(j, 4) & Replace(Replace(Split(Replace(ar2(jj), ", ", "|"))(4), "|", ", "), ".xlsx", "") & Chr(10)
        End If
    Next jj
Next j

For j = 1 To UBound(ar1)
    If Len(ar1(j, 3)) > 0 Then
        With CreateObject("Outlook.Application").CreateItem(0)
            .To = ar1(j, 2)
            .Subject = "Formulier(en) t.b.v. Verlenging Inhuurmedewerker"
            .body = "Hallo " & ar1(j, 1) & Chr(10) & Chr(10) & "In de bijlage(n) de gegeven(s) van inhuurmedewerker(s):" & Chr(10) & ar1(j, 4) & Chr(10) & _
            "Wil je zo vriendelijk zijn om de groen gekleurde cellen in te vullen?" & Chr(10) & _
            "Na ondertekening kan je het formulier als scan versturen naar Inhuur@test.nl" & Chr(10) & _
            "Hierna wordt het e.e.a. verwerkt" & Chr(10) & Chr(10) & _
            "Dank alvast voor je medewerking"
            For jj = 0 To UBound(Split(Mid(ar1(j, 3), 2), "|"))
                .attachments.Add Split(Mid(ar1(j, 3), 2), "|")(jj)
            Next jj
            .display '.send
        End With
    End If
Next j
End Sub

Zelf zou ik nog iets mee laten lopen dat als iets verstuurd is dit niet nogmaals gebeurt.

 

[HSV]

Om verkeerde data te voorkomen.

.[C8].Resize(6) = Application.Transpose(Array(ar(j, 1), ar(j, 14), ar(j, 9), ar(j, 8), ar(j, 4), ar(j, 5)))
.[c14] = cdate(ar(j, 11))

 

[peter59]

Hallo VenA en Harry

Dank voor jullie suggesties/toevoegingen.
Met deze suggesties/toevoegingen ga ik eens mijn tanden op stuk bijten.

@VenA
Ik heb de div. bestandjes geheel moeten "slopen" om het e.e.a. met .rar te kunnen uploaden.
Er kan tot max. 100Kb worden ge-upload.
Maar het valt mij op dat jouw voorbeeldbestandje 143Kb groot is.
Hoe is dit mogelijk?

Nogmaals dank voor jullie opmerkingen en suggesties.

Mvg
Peter

 

[VenA]

Hoe is dit mogelijk?

Gewoon de moderatie omkopen

Als je een bestand opslaat als binair bestand (.xlsb) dan wordt het bestand al gecomprimeerd en je mag om mij onbekende reden zo'n bestand tot 1 MB uploaden.

Als ik jouw bestand echt schoon maak kom ik maar tot 27Kb. Lege rijen/kolommen lijken vaak leeg maar zijn dat niet.

Zie ook de tweede code in #9