Alleen ingevulde rijen kopieren naar ander tabblad

[jv345]

Op dit forum heb ik verschillende macro's gevonden voor een oplossing van mijn vraag.
Onder andere van Wigi.

Wat ik wil bereiken is het volgende:
Op een tabblad staan meerdere tabellen. Door een gebruiker worden deze ingevuld.
Voorbeeld: de ene tabel heeft 5 ingevulde regels en de andere bijv 1.
Ik wil echter alleen de ingevulde regels kopieren naar een ander tabblad.


De macro die ik gevonden heb is de volgende:

Sub VindWAAR()
  
    Dim c As Range
    Dim firstAddress As String
    
    With Sheets("Menu").Range("A7:N200")
        Set c = .Find(1, LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.EntireRow.Copy Sheets("Blad1").Range("A" & Rows.Count).End(xlUp).Offset(1)

                'c.Offset(0, -6).Resize(1, 7).Copy Sheets("Blad1").Range("A" & Rows.Count).End(xlUp).Offset(1)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With

End Sub

Deze doet wel wat: vele keren knipperen op het scherm en uiteindelijk wordt er 1 kolomkop zichtbaar.
Waar zit de (denkfout)?

 

[etri]

Wat denk je van deze macro? Via "Selection.SpecialCells(xlCellTypeConstants, 23).Select" selecteer je namelijk automatisch al alleen de cellen met een waarde. Scheelt je weer programmeren

Public Sub KopoieerGevuldeCellen()
    Dim col As Integer
    Dim myrange As Range

    'Selecteer de kolommen in het gebied met de getallen (A7:N200) één voor één
    For col = 1 To 14
        'Activeer eerst de sheet met de gegevens
        Worksheets(1).Activate
        
        'Selecteer het gebied met de getallen (A7:N200) in Sheet1
        'let op: A7 = cell(7,1) en N200 = cell(200,14)
        Range(Cells(7, col), Cells(200, col)).Select
        
        'Indien de selectie minstens ingevulde cel bevat ga alleen dan door
        '(anders krijg je een error!)
        If Not RangeIsEmpty(Selection) Then
            
            'Selecteer alleen de ingevulde cellen
            Selection.SpecialCells(xlCellTypeConstants, 23).Select
            'Kopieer de ingevulde cellen
            Selection.Copy
            
            'Selecteer een andere sheet
            Sheets("Sheet2").Activate
            'Selecteer de cell waar de waarden moeten komen
            Range(Cells(1, col), Cells(1, col)).Select
            'en plak de waarden
            ActiveSheet.Paste
        End If
    Next col
End Sub

Function RangeIsEmpty(ByVal SourceRange As Range) As Boolean
'Geeft TRUE terug indien de selectie leeg is is
  
  RangeIsEmpty = (WorksheetFunction.CountA(SourceRange) = 0)

End Function

 

[jv345]

Etri,

Bedankt voor je reactie.
De macro geeft evenwel een foutcode bij het kopieren van de cellen.
Ik heb voor de duidelijkheid een voorbeelddocument bijgesloten.
Alleen de ingevulde cellen uit de tabellen, dus niet de tabelkoppen en opmaak hiervan moeten gekopieerd worden.
Ik hoop dat je weet wat er aan de hand is.

 

[etri]

De functie werkt alleen voor 1 kolom. Vandaar dat de code ook alle kolommen afloopt. Doordat rij 22, 39 etc. gemergde cellen zijn van 3 kolommen, wordt bij het selecteren van kolom 3 ("C") ook automatisch 4 en 5 geselecteerd (dus "D" en "E"). Aangezien het kopieren van speciale cellen alleen maar mag voor 1 kolom, krijg je een foutmelding.

Oplossing/bypass: maak van de gemergde cellen weer aparte cellen...

 

[jv345]

Etri,

Bedankt voor je reactie.
Het zegt mij echter niets (gemengde cellen en dergelijke).
Is er een oplossing voor mijn vraag?

 

[etri]

Ja, en die geef ik je...

Er zijn meerdere cellen samengevoegd tot 1 cel. Als je dat ongedaan maakt (en dan moet je natuurlijk wel eventjes naar de opmaak kijken, want die zal dan veranderen), dan werkt de macro wel!

Een voorbeeld cel is C5. Die cel is een samenvoeging van C5, D5 en E5. Als je op C5 klikt en dan op Shift+F2 (of rechtermuisknop en dan menuoptie "Format Cells...") dan zie je in het tweede tabblad ("Alignment") drie hokjes die je kunt aanvinken. De onderste heet "Merge cells" ("Cellen samenvoegen" o.i.d.). Die staat aangevinkt en moet je uitvinken.

Doe dit voor alle samengevoegde cellen. Et voila!

 

[jv345]

Etri,

Oke van die samengestelde cellen snap ik maar.......die wil ik ook helemaal niet zien.
Wat ik wil proberen zijn die regels waarbij in ieder geval de kolom B t/m N is ingevuld met cijfers.
De kolomkoppen en samengevoegde cellen moeten niet mee doen.
Ook als ik de macro laat beginnen op rij 9 gaat het niet goed.
Volgens mij ligt de oplossing in het zoeken en vinden van rijen waarbij in ieder geval olom B ingevuld is, dan de volgende rij zoeken en uiteindelijk de gevonden rijen kopieren naar een ander tabblad.
Althans dat is mijn mening maar ik krijg het niet voor elkaar om dit te vertalen in VBA-code.
Zie ik het nu echt fout??

 

[jv345]

Etri,

Ik heb je raad opgevolgd en de samengestelde cellen verwijderd. De macro loopt nu inderdaad door maar het resultaat is niet hetgeen ik verwachte.
Het gaat mij dus alleen om de 4 ingevulde rijen uit mijn voorbeeld. Niets meer en niets minder.

 

[etri]

Geef eens in blad1 aan (dat moet je dan maar even handmatig doen!) wat je als resultaat wilt hebben. Wil je wel/geen headers. Moeten de rijen direct onder elkaar? Etc.

Al deze vragen beantwoord je voor mij, door even een voorbeeld te geven...

 

[etri]

Wellicht dat deze code wel werkt?!? Let er wel op dat alle cellen die blanco zijn, ook daadwerkelijk leeg zijn! Dus niet een spatie o.i.d.
Om safe te zijn: selecteer bijvoorbeeld alle legen cellen en druk op de Delete knop

Code is:

Public Sub KopieerGevuldeCellen()
    Dim lrow1 As Long
    Dim lrow2 As Long
    Dim OrgRange As Range
    Dim CopyRange As Range

    lrow2 = 1 'start op blad1 op rij 1
    
    Sheets("Menu").Activate
    
    Set OrgRange = Range("B9:N18")
    lrow1 = OrgRange.Cells(OrgRange.Rows.Count, 1).End(xlUp).Row
    Set CopyRange = Range(Cells(9, 2), Cells(lrow1, 14))
    CopyRange.Copy
    Range("Blad1!A" & CStr(lrow2)).PasteSpecial xlPasteValuesAndNumberFormats
    lrow2 = lrow2 + CopyRange.Rows.Count 'start op blad1 op rij 1 + al ingevulde rijen
    
    Set OrgRange = Range("B26:N35")
    lrow1 = OrgRange.Cells(OrgRange.Rows.Count, 1).End(xlUp).Row
    Set CopyRange = Range(Cells(26, 2), Cells(lrow1, 14))
    CopyRange.Copy
    Range("Blad1!A" & CStr(lrow2)).PasteSpecial xlPasteValuesAndNumberFormats
    lrow2 = lrow2 + CopyRange.Rows.Count 'start op blad1 op rij 1 + al ingevulde rijen
    
    Set OrgRange = Range("B43:N52")
    OrgRange.Cells(OrgRange.Rows.Count, 1).Select
    Selection.End(xlUp).Select
    lrow1 = OrgRange.Cells(OrgRange.Rows.Count, 1).End(xlUp).Row
    Set CopyRange = Range(Cells(43, 2), Cells(lrow1, 14))
    CopyRange.Copy
    Range("Blad1!A" & CStr(lrow2)).PasteSpecial xlPasteValuesAndNumberFormats
    lrow2 = lrow2 + CopyRange.Rows.Count 'start op blad1 op rij 1 + al ingevulde rijen
    
End Sub

Succes!

 

[jv345]

Etri,

Ik heb een voorbeeldje gemaakt op Blad 1.
Hierin zie je dus gewoon alleen de regels die van kolom B t/m N ingevuld zijn. Geen headers en dergelijke.

Ik heb je andere macro uitgeprobeerd.
Bijna goed. Vreemde is dat ik niet alle rijen krijg (de laatste ontbreekt bijvoorbeeld) Ook de waarde uit cel C9 zie ik niet.
Als ik je macro goed begrijp ( ik ben geen expert ) is dat je bereiken maakt van de tabellen.

Deze tabellen worden met datavalidatie gevuld ( dat zijn oa de samengestelde velden in mijn voorbeeld) en er zit een macro aan gekoppeld als er eventueel te weinig regels in de tabel zijn. Dan wordt dit uitgebreid met een extra regel.
De oplossing om "vaste blokken" te nemen gaat dan volgens mij niet meer werken.
Kortom: ik wil wellicht het onmogelijke.

 

[etri]

Bijna goed. Vreemde is dat ik niet alle rijen krijg (de laatste ontbreekt bijvoorbeeld)

Dat komt omdat de regels onder die laatste rij toch nog een (onzichtbare) waarde bevatten. Als je alle rijen onder de laatste rij selecteert en dan de waarden verwijderd (DELETE knop), dan werkt het wel... Bij mij tenminste

 

[etri]

Deze tabellen worden met datavalidatie gevuld ( dat zijn oa de samengestelde velden in mijn voorbeeld) en er zit een macro aan gekoppeld als er eventueel te weinig regels in de tabel zijn. Dan wordt dit uitgebreid met een extra regel.
De oplossing om "vaste blokken" te nemen gaat dan volgens mij niet meer werken.
Kortom: ik wil wellicht het onmogelijke.

Dat kan wel, door het Change event van de sheet Info te gebruiken. Elke keer als een gebruiker een regel toevoegt (of verwijderd), dan kun je dat zien in dat event. Als je dus merkt dat een gebruiker in blok 2 een regel toevoegt, dan kun je de range van blok 2 ook met een regel uitbreiden en blok 3 een regel lager laten starten.

Het is wel wat boekhouding, maar volgens mij dus wel zo safe...en misschien de enige oplossing? Je zult namelijk hoe dan ook moeten aangeven waar de data staat en waar de headers/titels, want die laatste wil je niet mee kopieren...

Succes!

 

[jv345]

Etri,

Bedankt voor je reactie.
De optie van Change-event "info" kan inderdaad werken maar in de praktijk spreek ik over tientallen tabellen die door tientallen medewerkers ingevuld gaan worden.
Het wordt dan heel veel handwerk.
Op zich snap ik je conclusie dat het wel "veiliger" is maar ik had gehoopt dat dit met een macro op te lossen was.

Wat ik nu gedaan hebt is een filter op het hele tabblad gezet. Via de filter mogelijkheid laat ik een aangepaste selectie uitvoeren. ( kolom B is als de rij verder ingevuld is altijd groter dan 50000 ). Hierna via Ga naar-Speciaal alleen de zichtbare cellen gekopieerd naar een ander tabblad. Plakken speciaal-waarden.

Ik heb eea opgenomen met de macro-recorder want het zelf schrijven van de code lukt mij ( nog ) niet.
Dit werkt maar omdat er vele bestanden extern worden gevuld, wordt het toch een zeer uitgebreid verhaal.
Wellicht heeft iemand nog een briljante ingeving.