Alle bruikbare data uit een tabel kopiëren

[icecube87]

Hallo,

ik heb een excel document met een tabblad "Plakken".
Hierop bevindt zich een knop "plakken", welke een tabel die de gebruiker heeft gekopieerd in het aangemaakt tabblad "Template (NUMMER)" plakt. Nummer loopt op, aangezien er steeds een kopie template wordt gemaakt. Maar dat is verder niet van belang.

In het voorbeeld zie je op tabblad "template (2)" de tabel met gegevens staan.
Nu wil ik graag dat de volgende gegevens naar het tabblad "opslaan" gekopieerd worden:

1. Datum
2. Artikelnummer
3. Artikelnaam

Maar de gekopieerde tabel is, zoals je ziet, gescheiden met regels "vulgebied".
Hoe kan ik nou enkel de gewenste data selecteren?


Wellicht belangrijk om te weten: de tabel zoals geplakt op "template (2)" is dagelijks variërend. Dus per "vulgebied" kunnen meer of minder artikelen staan.
De opmaak is echter wel altijd hetzelfde.


EDIT:

Ik denk dat ik iets gevonden heb dat zou kunnen werken:

Option Explicit

Sub DeleteRow()
 
Dim i As Long
Dim rng As Range
 
With ActiveWorkbook.Sheets(1)
 
    For i = 100000 To 1 Step -1
 
        With .Cells(i, "C")
         
             If .Value = "Vulgebied" Then
             
                If rng Is Nothing Then
 
                    Set rng = .Cells
 
                Else
 
                    Set rng = Application.Union(rng, .Cells)
 
                End If
 
             End If
 
        End With
 
    Next i
 
    If Not rng Is Nothing Then rng.EntireRow.Delete
 
End With
 
End Sub

Alleen het woord "vulgebied" heeft telkens een ander nummer er achter staan, hoe kan ik dit script aanpassen zodat hij alle rijen met "vulgebied" verwijderd?

 

[edmoor]

Zo?

If Left(.Value, 9) = "Vulgebied" Then

 

[icecube87]

Dat zou wellicht de oplossing kunnen zijn, maar ik krijg bij de regel " With .Cells(i, "A")" > Door object of toepassing gedefinieerde fout (1004)


Zelf heb ik dit gemaakt:

Sub DeleteRows()
    Dim rng As Range, cell As Range
    Dim MyValue As String
    Dim LastRow As Long
    
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    
    
      

Set rng = Worksheets("template (2)").Range("A1:A" & LastRow)

For Each cell In rng

        MyValue = Left(cell.Value, 3)
         
    
        If MyValue = "Vul" Or MyValue = "Art" Then
 
        
            cell.EntireRow.Delete
 
        End If

Next cell

Worksheets("template (2)").Range("C1:C" & Cells(Rows.Count, 1).End(xlUp).Row).Replace What:=".", Replacement:="-", SearchOrder:=xlByColumns
Worksheets("template (2)").Range("A1:C" & LastRow).Copy
Worksheets("Opslaan").Range("A2").PasteSpecial Paste:=xlPasteValues

Dat werkt wel, maar als er 2 regels onder elkaar staan die verwijderd moeten worden, wordt de 2e regel telkens overgeslagen.
Kennelijk moet je het script dat van onder naar boven laten lopen, maar in mijn code weet ik niet hoe dat werkt.

 

[edmoor]

Maak er eens dit van:

Sub DeleteRow()
    Dim i As Long
    Dim rng As Range
     
    With ActiveWorkbook.Sheets("template (2)")
        For i = 2 To .UsedRange.Rows.Count
            If Left(.Cells(i, "A").Value, 9) = "Vulgebied" Then
               If rng Is Nothing Then
                   Set rng = .Cells(i, "A")
               Else
                   Set rng = Union(rng, .Cells(i, "A"))
               End If
            End If
        Next i
        If Not rng Is Nothing Then rng.EntireRow.Delete
    End With
End Sub

 

[gast0660]

In het voorbeeld zie je op tabblad "template (2)" de tabel met gegevens staan.
Nu wil ik graag dat de volgende gegevens naar het tabblad "opslaan" gekopieerd worden:
1. Datum
2. Artikelnummer
3. Artikelnaam

Voor de originele vraag, is dit de bedoeling?
Bekijk bijlage OOS VB.xls

 

[icecube87]

Het probleem was inderdaad dat het aantal ingegeven rijen niet aanwezig was. Ik heb nu de laatste rij opgezocht en deze ingevoerd als waarde i.p.v. 100000. Nu werkt het.
@gast0660: ook bedankt voor de hulp.

Nog een aanvullende vraag. Ik wil nu in kolom D een formule invoeren die rij-afhankelijk opereert.
Ik heb daarvoor deze code:

Dim i As Long
 
With ActiveWorkbook.Sheets("Opslaan")
 
    For i = LastRow To 1 Step -1
 
        If .Cells(i, "D") = "" Then
        
        
            .Cells(i, "D").Value = "=TEKST(C&i; "dddd")"
 
        End If
 
    Next i
 
End With

Alleen dit stuk: "=TEKST(C&i; "dddd")" geeft de fout: Comileerfout, syntaxisfout

Dit komt denk ik door de "" , maar de formule moet juist tussen "" . Hoe kan ik dat aanpassen?

 

[edmoor]

Wijzig de ; in een , en .Value in .Formula

Of maak er dit van:

.Cells(i, "D").Value = Format(Range("C"&i), "dddd"))

 

[icecube87]

Door de formule te wijzigen met een , i.p.v. ; werkt het inderdaad. Bedankt.

P.s. De "dddd" moet dan ook tussen dubbele quotes, dus ""dddd"".

 

[VenA]

Niet dat ik er veel van begrijp maar is zoiets niet voldoende?

Sub VenA()
  On Error Resume Next
  With Sheets("template (2)")
    .Range("B2:B" & .Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(4).EntireRow.Delete
    ar = .Cells(1).CurrentRegion
  End With
  Sheets("Opslaan").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar) - 1, 3) = Application.Index(ar, Evaluate("row(2:" & UBound(ar) & ")"), Array(3, 1, 2))
End Sub

De datum staat toch in kolom A in het blad 'Opslaan'?

 

[HSV]

Structuur aanwennen en dan kan het gewoon met advancedfilter.
Blijft je template mooi intact.

 

[icecube87]

Niet dat ik er veel van begrijp maar is zoiets niet voldoende?

Sub VenA()
  On Error Resume Next
  With Sheets("template (2)")
    .Range("B2:B" & .Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(4).EntireRow.Delete
    ar = .Cells(1).CurrentRegion
  End With
  Sheets("Opslaan").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar) - 1, 3) = Application.Index(ar, Evaluate("row(2:" & UBound(ar) & ")"), Array(3, 1, 2))
End Sub

De datum staat toch in kolom A in het blad 'Opslaan'?

De datum staat in kolom A inderdaad. Maar het script werkt, ik moest de ; aanpassen naar een punt. Zie bericht hier boven.