• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Gegevens wegschrijven naar verschillende tabbladen

Status
Niet open voor verdere reacties.
danny147

danny147

Terugkerende gebruiker
Lid geworden
29 apr 2007
Berichten
4.744
Beste,

Volgende code werkt perfect voor 1 tabblad, maar wens deze naar alle tabbladen te verwijzen.

Code: 
Sub gegevens_overdragen()
Dim mySheetName As String
Dim i As Variant
Dim str As String
        Application.ScreenUpdating = False
        
        str = ActiveSheet.Name
        i = Application.Match(str, Blad2.Columns(1), 0)
        Sheets("Gegevens").Range("LK_Row_nummer") = i
        Sheets("gegevens").Range("F3") = Blad2.Cells(i, 2).Value
        With ThisWorkbook.Sheets("Output")
        With .Cells(2).CurrentRegion
        If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False
        .AutoFilter 15, Blad2.Cells(i, 2) & "*"
        Cells.Select
        Selection.ClearContents
        .Cells(2).CurrentRegion.Copy Destination:=Worksheets(str).Range("A1")
        Columns("A:O").EntireColumn.AutoFit
        Range("A1").Select
        Sheets("output").ShowAllData
                
        End With
        End With
        
        Application.ScreenUpdating = True
End Sub

Heb zitten experimenteren met :

Code: 
For x = 1 To ActiveWorkbook.Sheets.Count
next

Maar ik geraak er niet aan uit.
Hopelijk vinden julie de oplossing
 

Bijlagen

  • Test gegevens.xlsm
    50,1 KB · Weergaven: 41
Helpt dit u vooruit?

Code: 
Sub gegevens_overdragen()
Dim mySheetName As String
Dim i As Variant
Dim str As String
Application.ScreenUpdating = False
 For Each WS In ThisWorkbook.Sheets
     str = WS.Name
      If str <> "Output" And str <> "Gegevens" Then
        With Sheets("Gegevens")
           i = Application.Match(str, .Columns(1), 0)
            .Range("LK_Row_nummer") = i
            .Range("F3") = .Cells(i, 2).Value
        End With
        With ThisWorkbook.Sheets("Output")
         With .Cells(2).CurrentRegion
          If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False
            .AutoFilter 15, Blad2.Cells(i, 2) & "*"
          Cells.ClearContents
            .Cells(2).CurrentRegion.Copy Destination:=Worksheets(str).Range("A1")
          Columns("A:O").EntireColumn.AutoFit
          Range("A1").Select
          Sheets("output").ShowAllData
         End With
        End With
      End If
  Next
Application.ScreenUpdating = True
End Sub
 
Laatst bewerkt:
Beste Cobbe,

Als ik de code laat lopen vanuit tabblad Output, dan gaat het zeker niet en de inhoud wordt gevuld met allemaal lege rijen ertussen.
Laat ik deze lopen vanuit tabblad "LK100" dan krijg ik geen gegevens voor LK100, de rest wel en de kolommen worden niet aangepast van breedte.
Ergens loopt het verkeerd.
Kan jij het eens testen, het bestandje is in vorig bericht als bijlage toegevoegd.
 
Ik heb nu de code zo dat Blad LK100 geactiveerd wordt bij het drukken op de button in blad Gegevens.
Dan schijnt het goed te lopen zover ik kan beoordelen.
 

Bijlagen

  • Test gegevens(cobbe).xlsm
    59 KB · Weergaven: 66
Beste cobbe,

Ik krijg geen gegevens te zien voor LK100 en de kolommen worden niet van breedte aangepast.
Hoe is het bij jou ?
 
Je zou voor de kolombreedte deze regel moeten aanpassen:
Code: 
Worksheets(str).Columns("A:O").EntireColumn.AutoFit

Waarom je geen gegevens krijgt op LK100 zie ik niet zo direct, je zou dat in het filteren moeten nakijken of deze gegevens wel gevonden worden.
 
Beste Cobbe,

In bijlage het bestandje dat ik heb laten lopen met jouw code.
Dus voor LK100 zijn er geen gegevens te zien ???
Tijdens het filteren zijn ze wel te zien.
 

Bijlagen

  • Test gegevens(cobbe-Danny).xlsm
    63,1 KB · Weergaven: 48
Ik heb enkel een punt geplaatst en lijkt nu wel te werken.

Code: 
Sub gegevens_overdragen()
Dim mySheetName As String
Dim i As Variant
Dim str As String
Sheets("LK100").Activate
Application.ScreenUpdating = False
 For Each WS In ThisWorkbook.Sheets
     str = WS.Name
      If str <> "Output" And str <> "Gegevens" Then
        With Sheets("Gegevens")
           i = Application.Match(str, .Columns(1), 0)
            .Range("LK_Row_nummer") = i
            .Range("F3") = .Cells(i, 2).Value
        End With
        With ThisWorkbook.Sheets("Output")
         With .Cells(2).CurrentRegion
          If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False
            .AutoFilter 15, Blad2.Cells(i, 2) & "*"
          Worksheets(str).Cells.ClearContents
            [B][COLOR="#FF0000"].[/COLOR][/B]Cells(2).CurrentRegion.Copy Destination:=Worksheets(str).Range("A1")
          Worksheets(str).Columns("A:O").EntireColumn.AutoFit
          Range("A1").Select
          Sheets("output").ShowAllData
         End With
        End With
      End If
  Next
Application.ScreenUpdating = True
End Sub
 
Beste Cobbe,

Het werkt, heb de code volledig terug overgenomen.
Had enkel naar die punt gekeken in jouw berichtje maar blijkbaar had je nog iets aangepast
Nu nog een paar keer testen voordat ik deze op opgelost plaatst
 
Laatst bewerkt:
Die punt voor Cells stond er pertinent niet.
Bij mij werkt het naar behoren volgens mij.
Ik snap niet wat er mis gaat bij u.
 
Beste Cobbe,

Had vorig berichtje aangepast wat je blijkbaar niet hebt gelezen.
Nu loopt hij lekker, morgen op opgelost plaatsen maar eerst nog wat testen.
 
Beste Cobbe,

Bedankt voor de aanpassing.

Heb het een paar keer getest en ziet er goed uit.
Wat betreft die punt stond er wel bij

Code: 
.Cells(2).CurrentRegion.Copy Destination:=Worksheets(str).Range("A1")

Hetgeen veranderd is in de code is

Code: 
Worksheets(str).Cells.ClearContents

Zonder Worksheets(str). werkte het niet, hier zat de fout
Zie het verschil in post#2 en post#8

Nogmaals bedankt Cobbe :thumb::thumb::thumb:
 
Lijk mij een beetje complexe code.

Is dit niet voldoende?
Code: 
Sub VenA()
Dim sh As Worksheet
For Each sh In Sheets
  If sh.Name <> "Output" And sh.Name <> "Gegevens" Then
    With Sheets("Output").Cells(1).CurrentRegion
      .AutoFilter 15, Sheets("Gegevens").Columns(1).Find(sh.Name, , xlValues, xlWhole).Offset(, 1).Value & "*"
      .Copy sh.Cells(1)
      .AutoFilter 15
    End With
  End If
Next sh
End Sub
 
Beste VenA,

Ik bewonder je prestatie die je hier neerzet.

Alles kan beter en korter, maar zolang het werkt en geen kostbare tijd in beslag neemt is dit voor mij dik in orde.

Na 10 jaar dat ik al geregistreerd ben op Helpmij.nl hebben er al velen gevraagd of ik VBA niet een beetje onder de knie heb.
Nu ik zelf iets in elkaar gestoken heb mag ik best wel fier zijn voor wat het is :d
Je moet ook code schrijven die je ook begrijpt en dat heb ik volgens mij normen gedaan

Geraak ik er niet aan uit zoek ik een beetje hulp waarbij ik Cobbe, HSV, Ginger, WIGI, Roncancio, Warme bakkertje, Ron De Bruin en VenA zeer dankbaar voor ben in het verleden
 
Beste,

Kan ik volgende in een lijst plaatsen i.p.v. alles achter elkaar te plaatsen ?
Zou dan een lijst willen maken op tabblad Gegevens in kolom D

Code: 
 For Each WS In ThisWorkbook.Sheets
     str = WS.Name
     [COLOR="#FF0000"] If str <> "Output" And str <> "Gegevens" And str <> "Overzicht OLM" And str <> "Standtijd" And str <> "INFO" Then[/COLOR]
        With Sheets("Gegevens")

Output
Gegevens
Overzicht OLM
Standtijd
INFO
 
Bedoel je dit?
Code: 
Sub gegevens_overdragen()
    Dim mySheetName As String
    Dim i As Variant
    'Initialise Array
    Dim Uitsluiten(5) As String
    Uitsluiten(0) = "Output"
    Uitsluiten(1) = "Gegevens"
    Uitsluiten(2) = "Overzicht OLM"
    Uitsluiten(3) = "Standtijd"
    Uitsluiten(4) = "INFO"
    For Each WS In ThisWorkbook.Sheets

        If Not UBound(Filter(Uitsluiten, WS.Name)) >= 0 And WS.Name <> "" Then
            Sheets("LK100").Activate
            Application.ScreenUpdating = False
            With Sheets("Gegevens")
                i = Application.Match(WS.Name, .Columns(1), 0)
                .Range("LK_Row_nummer") = i
                .Range("F3") = .Cells(i, 2).Value
            End With
            With ThisWorkbook.Sheets("Output")
                With .Cells(2).CurrentRegion
                    If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False
                    .AutoFilter 15, Blad2.Cells(i, 2) & "*"
                    Worksheets(WS.Name).Cells.ClearContents
                    .Cells(2).CurrentRegion.Copy Destination:=Worksheets(WS.Name).Range("A1")
                    Worksheets(WS.Name).Columns("A:O").EntireColumn.AutoFit
                    Range("A1").Select
                    Sheets("output").ShowAllData
                End With
            End With

        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
Laatst bewerkt:
Beste Cobbe,

Via een lijst die op tabblad Gegevens staat. ("D1 : D15")
Zodat ik deze lijst kan aanvullen zonder dit in de code telkens te moeten doen.
 
Laatst bewerkt:
Hiervoor heeft MS speciaal advancedfilter ontworpen:

Code: 
Sub M_snb()
  With Sheets("output")
    .Cells(1, 20) = .Cells(1, 10).Value
   
    For Each it In Sheets
       .Cells(2, 20) = it.Name & "*"
       If Left(it.Name, 2) = "LK" Then .Cells(1).CurrentRegion.AdvancedFilter 2, .Cells(1, 20).CurrentRegion, it.Cells(1)
    Next
  End With
End Sub
 
Laatst bewerkt:
Je kan dat makkelijk oplossen al weet ik zeker dat je die array eenvoudiger kunt vullen, maar resultaat is gelijk:
Code: 
Dim Uitsluiten(15) As String
With Sheets("Gegevens")
    Uitsluiten(0) = .Range("D1")
    Uitsluiten(1) = .Range("D2")
    Uitsluiten(2) = .Range("D3")
    Uitsluiten(3) = .Range("D4")
    Uitsluiten(4) = .Range("D5")
    Uitsluiten(5) = .Range("D6")
    Uitsluiten(6) = .Range("D7")
    Uitsluiten(7) = .Range("D8")
    Uitsluiten(8) = .Range("D9")
    Uitsluiten(9) = .Range("D10")
    Uitsluiten(10) = .Range("D11")
    Uitsluiten(11) = .Range("D12")
    Uitsluiten(12) = .Range("D13")
    Uitsluiten(13) = .Range("D14")
    Uitsluiten(14) = .Range("D15")
 End With
 
Een uitsluitlijst is overbodig als de 'insluit'lijst eenzelfde onderscheidend kenmerk heeft bijv. left(it.name,2)="LK"; zie post #18
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan