gegevens uit meerdere werkbladen kopieren naar een ander werkblad

[wilcovisser]

Hallo,

op het werk houden wij bij hoeveel telefoontjes wij krijgen en waarover.
Momenteel heeft iedereen zijn eigen excel bestand (15 collega`s) en is het niet echt overzichtelijk.
We willen dit eigenlijk in 1 excel bestand zetten.
Het probleem bij 'werkmap delen' is dat we niet op hetzelfde werkblad kunnen werken omdat we met 4en tegelijk bezig kunnen zijn in dezelfde cel.
Dus heb ik een andere oplossing bedacht, en ben bijna klaar. Het laatste stuk kom ik niet uit.
Ik ben een amateur-vb`er. Ik hou van knippen/plakken, kopiëren en aanpassen, daarmee is het tot nu toe zelf gelukt.

Wat heb ik nu:
4 'dezelfde' formulieren. Op werkblad 1 open je formulier 'tafel 1' als je op tafel 1 zit.
Hier vul je in: Medewerker, beller, onderwerp. Daarna klik je op de knop 'opslaan'.
Op werkblad 'tafel 1' worden deze gegevens, evenals de datum en tijd, in kolom A t/m E geplakt.

hetzelfde voor tafel 2, 3 en 4.
Tot zover werkt alles.

Ik heb dus 4 tabbladen met gesprekken, met overal kolom A t/m E gevuld. De ene met meer rijen dan de ander.

Wat wil ik:
Ik wil dat alle gesprekken van tabbladen 'tafel 1' t/m 'tafel 4' in tabblad 'Overzicht' te zien zijn, onder elkaar.
Dus als op tafel 1 20 gesprekken zijn gevoerd, op tafel 2 geen, op tafel 3 en 4 beide 40 wil ik:
op tabblad 'overzicht' 100 gesprekken zien staan.
Daar zie ik dan van de hele maand alle gesprekken. Daar kan ik ze sorteren om informatie over de gesprekken inzichtelijk te krijgen.

Zouden jullie mij hierbij kunnen helpen zodat ik niet handmatig copy/paste moet gaan doen?


Sorry voor het lange verhaal, hopelijk is het wel duidelijk :d
mvg Wilco

 

[wilcovisser]

Het is me na 3 dagen dan eindelijk gelukt, d.m.v. een module.
Hieronder de module die ik heb gebruikt.
Ik heb in de code slechts tafel 1 en 2 gezet, anders word de code wat lang.
Mogelijk kunnen jullie hier zelf ook nog iets mee.
Hoewel het waarschijnlijk niet de snelste/beste oplossing is, werkt hij wel.

Function MaakOverzicht()

    Application.ScreenUpdating = False
    Sheets("Overzicht").[A2:M65536].ClearContents
    
'tafel X kopieren en plakken
        Sheets("Tafel 1").Select
        LastRowDest = Sheets("Overzicht").[A65536].End(xlUp).Row + 1
        LastRowCopy = Sheets("tafel 1").[A65536].End(xlUp).Row
        Sheets("tafel 1").Range([A2], Cells(LastRowCopy, 5)).Copy
        Sheets("Compleet").Cells(LastRowDest, 1).PasteSpecial
        
        Sheets("Tafel 2").Select
        LastRowDest = Sheets("Overzicht").[A65536].End(xlUp).Row + 1
        LastRowCopy = Sheets("tafel 2").[A65536].End(xlUp).Row
        Sheets("tafel 2").Range([A2], Cells(LastRowCopy, 5)).Copy
        Sheets("Compleet").Cells(LastRowDest, 1).PasteSpecial
        
    Application.Goto Sheets("Overzicht").[A1]
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

End Function

 

[Elsendoorn2134]

Wilco,

Vermoed dat je code toch niet goed werkt, bijvoorbeeld het woord "Overzicht" mag je niet gebruiken als sheet naam,
dit is een van de niet toegestane woorden, verder gebruik je ook een sheet "Compleet" in plaats van "Overzicht".
Tenslotte kopieer je slechts een Cel naar het "Compleet" terwijl dit volgens mij een hele regel moet bevatten.
Hierbij een aangepaste code die ook alle "Tafels" in het bestand af gaat.

Function MaakOverzicht()

Dim wSheet As Worksheet
Dim LastRowDest As Long
Dim LastRowCopy As Long

Application.ScreenUpdating = False                      'Zet screenupdate uit
Sheets("MijnOverzicht").[A2:M65536].ClearContents           'Verwijder oude gegevens
    
'tafel X kopieren en plakken
For Each wSheet In ActiveWorkbook.Sheets                'Loop door alle sheets
    If Left(wSheet.Name, 5) = "Tafel" Then              'als de naam van de sheet begint met "Tafel"
        LastRowDest = Sheets("MijnOverzicht").[A65536].End(xlUp).Row + 1    'zoek laatste regel overzicht sheet
        LastRowCopy = wSheet.[A65536].End(xlUp).Row                         'zoek laatste regel huidig sheet
        wSheet.Range("A2").Resize(LastRowCopy, 5).Copy _
            Destination:=Sheets("MijnOverzicht").Cells(LastRowDest, 1)      'Kopieer gegevens
    End If
Next
                
Application.ScreenUpdating = True                       'Zet screenupdate weer aan

End Function

Veel Succes.

 

[wilcovisser]

Hallo,

ik had de verkeerde code gekopieerd zie ik, ik had inderdaad 'overzicht' veranderd in 'compleet'.
Maar wat betreft kopieren van 1 cel? Dat volg ik niet helemaal. Bedoelde je dit stukje?

Sheets("tafel 1").Range([A2], Cells(LastRowCopy, 5)).Copy

Hier kopieert hij als het goed is range A2 t/m laatste rij, kolom E. (A2 - E..)

Maar enfin, de code die je plaatste werkt perfect, ik heb 1 werkblad hernoemt van 'andere tafel' naar 'tafel extra'.
En hij loopt als een trein, dank je wel daarvoor.